From 10fae36b8ec781c1ea7157a2a440d14a5defee71 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Fri, 20 Dec 2024 18:22:43 +0100 Subject: [PATCH] ppx: add the culprit json fragment in the error messages systematically. (#47) --- ppx/browser/dune | 14 +- ppx/browser/ppx_deriving_json_js.ml | 24 +- .../ppx_deriving_json_common.ml | 0 ppx/{native => common}/ppx_deriving_tools.ml | 21 +- ppx/{native => common}/ppx_deriving_tools.mli | 0 ppx/native/dune | 19 +- ppx/native/ppx_deriving_json_native.ml | 12 +- ppx/runtime/browser/dune | 10 + .../browser/ppx_deriving_json_classify.ml | 30 ++ .../browser/ppx_deriving_json_exception.ml | 1 + .../browser/ppx_deriving_json_runtime.ml | 66 +--- .../common/ppx_deriving_json_errors.ml | 109 ++++++ ppx/runtime/native/dune | 8 + .../native/ppx_deriving_json_classify.ml | 13 + .../native/ppx_deriving_json_exception.ml | 3 + .../native/ppx_deriving_json_runtime.ml | 55 ++- ppx/test/errors.t/deep_culprit.json | 21 ++ ppx/test/errors.t/dune | 5 + ppx/test/errors.t/dune-project | 1 + ppx/test/errors.t/extra_field.json | 12 + ppx/test/errors.t/missing_field.json | 10 + ppx/test/errors.t/ok.json | 11 + ppx/test/errors.t/prettify.ml | 28 ++ ppx/test/errors.t/run.t | 40 +++ ppx/test/errors.t/tag_as_string.json | 11 + ppx/test/errors.t/unknown_tag.json | 11 + ppx/test/errors.t/wide_culprit.json | 11 + ppx/test/errors.t/wrong_core_type.json | 11 + ppx/test/errors.t/wrong_core_type_wide.json | 11 + ppx/test/errors.t/wrong_tag_payload.json | 11 + ppx/test/poly.t | 54 +-- ppx/test/ppx_deriving_json_js.e2e.t | 2 +- ppx/test/ppx_deriving_json_js.t | 316 +++++++++--------- ppx/test/ppx_deriving_json_native.e2e.t | 2 +- ppx/test/ppx_deriving_json_native.t | 158 ++++----- 35 files changed, 714 insertions(+), 397 deletions(-) rename ppx/{native => common}/ppx_deriving_json_common.ml (100%) rename ppx/{native => common}/ppx_deriving_tools.ml (97%) rename ppx/{native => common}/ppx_deriving_tools.mli (100%) create mode 100644 ppx/runtime/browser/dune create mode 100644 ppx/runtime/browser/ppx_deriving_json_classify.ml create mode 100644 ppx/runtime/browser/ppx_deriving_json_exception.ml rename ppx/{ => runtime}/browser/ppx_deriving_json_runtime.ml (66%) create mode 100644 ppx/runtime/common/ppx_deriving_json_errors.ml create mode 100644 ppx/runtime/native/dune create mode 100644 ppx/runtime/native/ppx_deriving_json_classify.ml create mode 100644 ppx/runtime/native/ppx_deriving_json_exception.ml rename ppx/{ => runtime}/native/ppx_deriving_json_runtime.ml (75%) create mode 100644 ppx/test/errors.t/deep_culprit.json create mode 100644 ppx/test/errors.t/dune create mode 100644 ppx/test/errors.t/dune-project create mode 100644 ppx/test/errors.t/extra_field.json create mode 100644 ppx/test/errors.t/missing_field.json create mode 100644 ppx/test/errors.t/ok.json create mode 100644 ppx/test/errors.t/prettify.ml create mode 100644 ppx/test/errors.t/run.t create mode 100644 ppx/test/errors.t/tag_as_string.json create mode 100644 ppx/test/errors.t/unknown_tag.json create mode 100644 ppx/test/errors.t/wide_culprit.json create mode 100644 ppx/test/errors.t/wrong_core_type.json create mode 100644 ppx/test/errors.t/wrong_core_type_wide.json create mode 100644 ppx/test/errors.t/wrong_tag_payload.json diff --git a/ppx/browser/dune b/ppx/browser/dune index c6189e7..9285271 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) (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) @@ -36,7 +28,7 @@ (run echo "let () = Ppxlib.Driver.standalone ()")))) (copy_files# - (files ../native/ppx_deriving_json_common.ml)) + (files ../common/ppx_deriving_json_common.ml)) (copy_files# - (files ../native/ppx_deriving_tools.{ml,mli})) + (files ../common/ppx_deriving_tools.{ml,mli})) diff --git a/ppx/browser/ppx_deriving_json_js.ml b/ppx/browser/ppx_deriving_json_js.ml index 5437daf..63c7b6f 100644 --- a/ppx/browser/ppx_deriving_json_js.ml +++ b/ppx/browser/ppx_deriving_json_js.ml @@ -40,9 +40,9 @@ module Of_json = struct | Some default -> default | None -> [%expr - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x [%e - estring ~loc (sprintf "missing field %S" n.txt)]]]] + estring ~loc (sprintf "expected field %S to be present" n.txt)]]]] ) in [%expr @@ -65,13 +65,13 @@ 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 + Ppx_deriving_json_runtime.of_json_msg_error [%e estring ~loc (sprintf "expected a JSON object")]] - let ensure_json_array_len ~loc n len = + let ensure_json_array_len ~loc n len x = [%expr if Stdlib.( <> ) [%e len] [%e eint ~loc n] then - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_msg_error ~json:[%e x] [%e estring ~loc (sprintf "expected a JSON array of length %i" n)]] @@ -89,7 +89,7 @@ module Of_json = struct 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 + Ppx_deriving_json_runtime.of_json_error ~json:[%e x] [%e estring ~loc (sprintf "expected a JSON array of length %i" n)]] @@ -111,14 +111,14 @@ module Of_json = struct let tag = (Obj.magic tag : string) in [%e body] else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:[%e x] "expected a non empty JSON array with element being a \ string" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:[%e x] "expected a non empty JSON array" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:[%e x] "expected a non empty JSON array"] let derive_of_variant_case derive make c next = @@ -128,7 +128,7 @@ module Of_json = struct let n = Option.value ~default:n (vcs_attr_json_name r.rcd_ctx) in [%expr if Stdlib.( = ) tag [%e estring ~loc:n.loc n.txt] then ( - [%e ensure_json_array_len ~loc 2 [%expr len]]; + [%e ensure_json_array_len ~loc 2 [%expr len] [%expr x]]; let fs = Js.Array.unsafe_get array 1 in [%e ensure_json_object ~loc [%expr fs]]; [%e @@ -141,7 +141,7 @@ module Of_json = struct let arity = List.length t.tpl_types in [%expr if Stdlib.( = ) tag [%e estring ~loc:n.loc n.txt] then ( - [%e ensure_json_array_len ~loc (arity + 1) [%expr len]]; + [%e ensure_json_array_len ~loc (arity + 1) [%expr len] [%expr x]]; [%e if Stdlib.( = ) arity 0 then make None else @@ -153,7 +153,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"]) + [%expr Ppx_deriving_json_runtime.of_json_msg_error "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/native/ppx_deriving_json_common.ml b/ppx/common/ppx_deriving_json_common.ml similarity index 100% rename from ppx/native/ppx_deriving_json_common.ml rename to ppx/common/ppx_deriving_json_common.ml diff --git a/ppx/native/ppx_deriving_tools.ml b/ppx/common/ppx_deriving_tools.ml similarity index 97% rename from ppx/native/ppx_deriving_tools.ml rename to ppx/common/ppx_deriving_tools.ml index 04215b1..60e9e8a 100644 --- a/ppx/native/ppx_deriving_tools.ml +++ b/ppx/common/ppx_deriving_tools.ml @@ -503,6 +503,21 @@ module Conv = struct method! derive_of_variant td cs x = let loc = td.ptype_loc in + let error_message = + Printf.sprintf "expected %s" + (cs + |> List.map ~f:(fun c -> + let name = c.pcd_name in + match c.pcd_args with + | Pcstr_record _fs -> + Printf.sprintf {|["%s", { _ }]|} name.txt + | Pcstr_tuple li -> + Printf.sprintf {|["%s"%s]|} name.txt + (li + |> List.map ~f:(fun _ -> ", _") + |> String.concat ~sep:"")) + |> String.concat ~sep:" or ") + in let cs = repr_variant_cases cs in let cases = List.fold_left cs @@ -510,10 +525,8 @@ module Conv = struct [ [%pat? _] --> [%expr - raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))]; + Ppx_deriving_json_runtime.of_json_error ~json:x + [%e estring ~loc error_message]]; ] ~f:(fun next (c : constructor_declaration) -> let ctx = Vcs_ctx_variant c in diff --git a/ppx/native/ppx_deriving_tools.mli b/ppx/common/ppx_deriving_tools.mli similarity index 100% rename from ppx/native/ppx_deriving_tools.mli rename to ppx/common/ppx_deriving_tools.mli diff --git a/ppx/native/dune b/ppx/native/dune index 01c1a7b..71227a9 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) (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) @@ -37,3 +26,9 @@ (with-stdout-to %{target} (run echo "let () = Ppxlib.Driver.standalone ()")))) + +(copy_files# + (files ../common/ppx_deriving_json_common.ml)) + +(copy_files# + (files ../common/ppx_deriving_tools.{ml,mli})) \ No newline at end of file diff --git a/ppx/native/ppx_deriving_json_native.ml b/ppx/native/ppx_deriving_json_native.ml index e1b8c43..63ef025 100644 --- a/ppx/native/ppx_deriving_json_native.ml +++ b/ppx/native/ppx_deriving_json_native.ml @@ -47,8 +47,8 @@ module Of_json = struct if allow_extra_fields then [%expr ()] else [%expr - Ppx_deriving_json_runtime.of_json_error - (Stdlib.Printf.sprintf "unknown field: %s" name)] + Ppx_deriving_json_runtime.of_json_error ~json:x + (Stdlib.Printf.sprintf {|did not expect field "%s"|} name)] in let cases = List.fold_left (List.rev fs) ~init:[ fail_case ] @@ -81,10 +81,10 @@ module Of_json = struct | Some default -> default | None -> [%expr - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x [%e estring ~loc:key.loc - (sprintf "missing field %S" key.txt)]]]] + (sprintf "expected field %S" key.txt)]]]] )) in pexp_record ~loc fields None @@ -109,7 +109,7 @@ module Of_json = struct xpatt --> build_tuple ~loc derive xexprs t.tpl_types; [%pat? _] --> [%expr - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:[%e x] [%e estring ~loc (sprintf "expected a JSON array of length %i" n)]]; @@ -127,7 +127,7 @@ module Of_json = struct [%expr fs] Fun.id; [%pat? _] --> [%expr - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:[%e x] [%e estring ~loc (sprintf "expected a JSON object")]]; ] diff --git a/ppx/runtime/browser/dune b/ppx/runtime/browser/dune new file mode 100644 index 0000000..4554cf2 --- /dev/null +++ b/ppx/runtime/browser/dune @@ -0,0 +1,10 @@ +(library + (public_name melange-json.ppx-runtime) + (name ppx_deriving_json_js_runtime) + (libraries melange-json) + (wrapped false) + (modes melange)) + + +(copy_files# + (files ../common/ppx_deriving_json_errors.ml)) \ No newline at end of file diff --git a/ppx/runtime/browser/ppx_deriving_json_classify.ml b/ppx/runtime/browser/ppx_deriving_json_classify.ml new file mode 100644 index 0000000..e18ba08 --- /dev/null +++ b/ppx/runtime/browser/ppx_deriving_json_classify.ml @@ -0,0 +1,30 @@ +type t = Js.Json.t + +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 Js.Float.isFinite v && Js.Math.floor_float v == 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) \ No newline at end of file diff --git a/ppx/runtime/browser/ppx_deriving_json_exception.ml b/ppx/runtime/browser/ppx_deriving_json_exception.ml new file mode 100644 index 0000000..ab00204 --- /dev/null +++ b/ppx/runtime/browser/ppx_deriving_json_exception.ml @@ -0,0 +1 @@ +exception Of_json_error = Json.Decode.DecodeError diff --git a/ppx/browser/ppx_deriving_json_runtime.ml b/ppx/runtime/browser/ppx_deriving_json_runtime.ml similarity index 66% rename from ppx/browser/ppx_deriving_json_runtime.ml rename to ppx/runtime/browser/ppx_deriving_json_runtime.ml index 56241ce..ef824e7 100644 --- a/ppx/browser/ppx_deriving_json_runtime.ml +++ b/ppx/runtime/browser/ppx_deriving_json_runtime.ml @@ -4,7 +4,8 @@ let to_json t = t let of_json t = t let to_string t = Js.Json.stringify t -exception Of_string_error of string + +include Ppx_deriving_json_errors let of_string s = try Js.Json.parseExn s @@ -24,10 +25,6 @@ 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 (Json_error msg)) - let unexpected_variant_error tag = raise (Of_json_error (Unexpected_variant tag)) @@ -62,11 +59,11 @@ end module Of_json = struct let string_of_json (json : t) : string = if Js.typeof json = "string" then (Obj.magic json : string) - else of_json_error "expected a string" + else of_json_error ~json "expected a string" let bool_of_json (json : t) : bool = if Js.typeof json = "boolean" then (Obj.magic json : bool) - else of_json_error "expected a boolean" + else of_json_error ~json "expected a boolean" let is_int value = Js.Float.isFinite value && Js.Math.floor_float value == value @@ -75,30 +72,30 @@ module Of_json = struct if Js.typeof json = "number" then let v = (Obj.magic json : float) in if is_int v then (Obj.magic v : int) - else of_json_error "expected an integer" - else of_json_error "expected an integer" + else of_json_error ~json "expected an integer" + else of_json_error ~json "expected an integer" let int64_of_json (json : t) : int64 = if Js.typeof json = "string" then let v = (Obj.magic json : string) in match Int64.of_string_opt v with | Some v -> v - | None -> of_json_error "expected int64 as string" - else of_json_error "expected int64 as string" + | None -> of_json_error ~json "expected int64 as string" + else of_json_error ~json "expected int64 as string" let float_of_json (json : t) : float = if Js.typeof json = "number" then (Obj.magic json : float) - else of_json_error "expected a float" + else of_json_error ~json "expected a float" let unit_of_json (json : t) = if (Obj.magic json : 'a Js.null) == Js.null then () - else of_json_error "expected null" + else of_json_error ~json "expected null" let array_of_json v_of_json (json : t) = if Js.Array.isArray json then let json = (Obj.magic json : Js.Json.t array) in Js.Array.map ~f:v_of_json json - else of_json_error "expected a JSON array" + else of_json_error ~json "expected a JSON array" let list_of_json v_of_json (json : t) = array_of_json v_of_json json |> Array.to_list @@ -117,50 +114,21 @@ module Of_json = struct let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "Ok" then ( if Stdlib.( <> ) len 2 then - of_json_error "expected a JSON array of length 2"; + of_json_error ~json "expected a JSON array of length 2"; Ok (ok_of_json (Js.Array.unsafe_get array 1))) else if Stdlib.( = ) tag "Error" then ( if Stdlib.( <> ) len 2 then - of_json_error "expected a JSON array of length 2"; + of_json_error ~json "expected a JSON array of length 2"; Error (err_of_json (Js.Array.unsafe_get array 1))) - else of_json_error "invalid JSON" + else of_json_error ~json {|expected ["Ok", _] or ["Error", _]|} else - of_json_error + of_json_error ~json "expected a non empty JSON array with element being a string" - else of_json_error "expected a non empty JSON array" - else of_json_error "expected a non empty JSON array" + else of_json_error ~json "expected a non empty JSON array" + else of_json_error ~json "expected a non empty JSON array" end module Primitives = struct include Of_json include To_json 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 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) -end diff --git a/ppx/runtime/common/ppx_deriving_json_errors.ml b/ppx/runtime/common/ppx_deriving_json_errors.ml new file mode 100644 index 0000000..68dca20 --- /dev/null +++ b/ppx/runtime/common/ppx_deriving_json_errors.ml @@ -0,0 +1,109 @@ +exception Of_string_error of string + +include Ppx_deriving_json_exception +module Classify = Ppx_deriving_json_classify + +let with_buffer f = + let buffer = Buffer.create 1 in + f (Buffer.add_string buffer); + Buffer.contents buffer + +let iteri_last f li = + let rec loop i li = + match li with + | [] -> () + | [ elt ] -> f ~is_last:true i elt + | elt :: li -> + f ~is_last:false i elt; + loop (i + 1) li + in + loop 0 li + +let show_json_type json = + json |> Classify.classify |> function + | `Assoc _ -> "object" + | `Bool _ -> "bool" + | `Float _ -> "float" + | `Int _ -> "int" + | `List _ -> "array" + | `Null -> "null" + | `String _ -> "string" + +let show_json_error ?depth ?width json = + with_buffer (fun emit -> + let rec loop ?depth json = + let json = Classify.classify json in + let depth = Option.map (fun i -> i - 1) depth in + match depth with + | Some 0 -> emit "_" + | _ -> ( + match json with + | `Assoc assoc -> + emit "{"; + iteri_last + (fun ~is_last i (k, v) -> + match width with + | Some width when i = width -> emit "..." + | Some width when i > width -> () + | _ -> + emit {|"|}; + emit k; + emit {|": |}; + let depth = Option.map (fun i -> i - 1) depth in + loop ?depth v; + if not is_last then emit {|, |}) + assoc; + emit "}" + | `Bool bool -> emit (if bool then "true" else "false") + | `Float float -> emit (string_of_float float) + | `Int int -> emit (string_of_int int) + | `List li -> + emit "["; + iteri_last + (fun ~is_last i elt -> + match width with + | Some width when i = width -> emit "..." + | Some width when i > width -> () + | _ -> + loop ?depth elt; + if not is_last then emit ", ") + li; + emit "]" + | `Null -> emit "null" + | `String str -> ( + let len = String.length str in + match width with + | Some width + when len > (width * 2) + 5 + (* I add 5 to account for the [" ... "] I am adding in that case *) + -> + emit {|"|}; + emit (String.escaped (String.sub str 0 width)); + emit " ... "; + emit {|"|} + | _ -> + emit {|"|}; + emit (String.escaped str); + emit {|"|})) + in + + (loop ?depth:(Option.map (fun i -> i + 1) depth)) json) + +let of_json_msg_error msg = raise (Of_json_error (Json_error msg)) + +let of_json_error ?(depth = 2) ?(width = 8) ~json msg = + of_json_msg_error + (with_buffer (fun emit -> + emit msg; + emit " but got "; + emit (show_json_error ~depth ~width json))) + +let of_json_error_type_mismatch json expected = + of_json_msg_error + (with_buffer (fun emit -> + emit "expected "; + emit expected; + emit " but got "; + emit (show_json_type json); + emit ": "; + emit (show_json_error ~depth:2 ~width:8 json))) diff --git a/ppx/runtime/native/dune b/ppx/runtime/native/dune new file mode 100644 index 0000000..7b4be00 --- /dev/null +++ b/ppx/runtime/native/dune @@ -0,0 +1,8 @@ +(library + (public_name melange-json-native.ppx-runtime) + (name ppx_deriving_json_native_runtime) + (wrapped false) + (libraries yojson)) + +(copy_files# + (files ../common/ppx_deriving_json_errors.ml)) \ No newline at end of file diff --git a/ppx/runtime/native/ppx_deriving_json_classify.ml b/ppx/runtime/native/ppx_deriving_json_classify.ml new file mode 100644 index 0000000..96102d8 --- /dev/null +++ b/ppx/runtime/native/ppx_deriving_json_classify.ml @@ -0,0 +1,13 @@ +type t = Yojson.Basic.t + + + 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 \ No newline at end of file diff --git a/ppx/runtime/native/ppx_deriving_json_exception.ml b/ppx/runtime/native/ppx_deriving_json_exception.ml new file mode 100644 index 0000000..17eb78c --- /dev/null +++ b/ppx/runtime/native/ppx_deriving_json_exception.ml @@ -0,0 +1,3 @@ +type error = Json_error of string | Unexpected_variant of string + +exception Of_json_error of error \ No newline at end of file diff --git a/ppx/native/ppx_deriving_json_runtime.ml b/ppx/runtime/native/ppx_deriving_json_runtime.ml similarity index 75% rename from ppx/native/ppx_deriving_json_runtime.ml rename to ppx/runtime/native/ppx_deriving_json_runtime.ml index f043e9b..64aaa17 100644 --- a/ppx/native/ppx_deriving_json_runtime.ml +++ b/ppx/runtime/native/ppx_deriving_json_runtime.ml @@ -1,5 +1,9 @@ +open Printf + type t = Yojson.Basic.t +include Ppx_deriving_json_errors + let to_json t = t let of_json t = t let to_string t = Yojson.Basic.to_string t @@ -10,24 +14,20 @@ let of_string s = try Yojson.Basic.from_string s with Yojson.Json_error msg -> raise (Of_string_error msg) -type error = Json_error of string | Unexpected_variant of string - -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" - | `Bool _ -> "bool" - | `Float _ -> "float" - | `Int _ -> "int" - | `List _ -> "array" - | `Null -> "null" - | `String _ -> "string" - -let of_json_error_type_mismatch json expected = - of_json_error - ("expected " ^ expected ^ " but got " ^ show_json_type json) +let () = + Printexc.register_printer (function + | Of_json_error (Json_error str) -> + Some + (sprintf + "Ppx_deriving_json_runtime.Of_json_error(Json_error {|%s|})" + str) + | Of_json_error (Unexpected_variant str) -> + Some + (sprintf + "Ppx_deriving_json_runtime.Of_json_error(Unexpected_variant \ + {|%s|})" + str) + | _ -> None) module To_json = struct let string_to_json v = `String v @@ -87,7 +87,7 @@ module Of_json = struct let unit_of_json = function | `Null -> () - | _ -> of_json_error "expected null" + | json -> of_json_error_type_mismatch json "expected null" let option_of_json v_of_json = function | `Null -> None @@ -105,23 +105,12 @@ module Of_json = struct 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" + | _ -> + of_json_error {|expected ["Ok"; _] or ["Error"; _]|} ~depth:2 + ~json end module Primitives = struct include To_json include Of_json 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 -end diff --git a/ppx/test/errors.t/deep_culprit.json b/ppx/test/errors.t/deep_culprit.json new file mode 100644 index 0000000..be2f888 --- /dev/null +++ b/ppx/test/errors.t/deep_culprit.json @@ -0,0 +1,21 @@ +{ + "a": ["Foo"], + "foo": [["A"], + ["Foo"], + ["B", 123], + ["C", 234, "hello"] + ], + "b": { + "a": ["Foo"], + "foo": [["A"], + ["Foo"], + ["B", 123], + ["C", 234, "hello"] + ], + "b": "where are you ?", + "c": [123, 234, 345], + "d": [123, [1.2, 2.3, 2.4], "i am here"] + }, + "c": [123, 234, 345], + "d": [123, [1.2, 2.3, 2.4], "i am here"] +} \ No newline at end of file diff --git a/ppx/test/errors.t/dune b/ppx/test/errors.t/dune new file mode 100644 index 0000000..3e95991 --- /dev/null +++ b/ppx/test/errors.t/dune @@ -0,0 +1,5 @@ +(executable + (name prettify) + (libraries yojson) + (preprocess + (pps melange-json-native.ppx))) diff --git a/ppx/test/errors.t/dune-project b/ppx/test/errors.t/dune-project new file mode 100644 index 0000000..b2559fa --- /dev/null +++ b/ppx/test/errors.t/dune-project @@ -0,0 +1 @@ +(lang dune 1.0) \ No newline at end of file diff --git a/ppx/test/errors.t/extra_field.json b/ppx/test/errors.t/extra_field.json new file mode 100644 index 0000000..7991653 --- /dev/null +++ b/ppx/test/errors.t/extra_field.json @@ -0,0 +1,12 @@ +{ + "a": ["Foo"], + "foo": [["A"], + ["Foo"], + ["B", 123], + ["C", 234, "hello"] + ], + "bar": "i am bar", + "b": "where are you ?", + "c": [123, 234, 345], + "d": [123, [1.2, 2.3, 2.4], "i am here"] +} \ No newline at end of file diff --git a/ppx/test/errors.t/missing_field.json b/ppx/test/errors.t/missing_field.json new file mode 100644 index 0000000..79cae47 --- /dev/null +++ b/ppx/test/errors.t/missing_field.json @@ -0,0 +1,10 @@ +{ + "a": ["Foo"], + "foo": [["A"], + ["Foo"], + ["B", 123], + ["C", 234, "hello"] + ], + "c": [123, 234, 345], + "d": [123, [1.2, 2.3, 2.4], "i am here"] +} \ No newline at end of file diff --git a/ppx/test/errors.t/ok.json b/ppx/test/errors.t/ok.json new file mode 100644 index 0000000..66e5fb7 --- /dev/null +++ b/ppx/test/errors.t/ok.json @@ -0,0 +1,11 @@ +{ + "a": ["Foo"], + "foo": [["A"], + ["Foo"], + ["B", 123], + ["C", 234, "hello"] + ], + "b": "where are you ?", + "c": [123, 234, 345], + "d": [123, [1.2, 2.3, 2.4], "i am here"] +} \ No newline at end of file diff --git a/ppx/test/errors.t/prettify.ml b/ppx/test/errors.t/prettify.ml new file mode 100644 index 0000000..6f0d833 --- /dev/null +++ b/ppx/test/errors.t/prettify.ml @@ -0,0 +1,28 @@ +open Ppx_deriving_json_runtime.Primitives + +type variant = + | A + | Foo + | B of int + | C of int * string + | D of { x : int; y : string } +[@@deriving json] + +type j = { + a : variant; + foo: variant list; + b : string; + c : int list; + d : int * float list * string; +} +[@@deriving json] + +let () = + In_channel.with_open_bin Sys.argv.(1) (fun file -> + file + |> In_channel.input_all + |> Yojson.Basic.from_string + |> j_of_json + |> j_to_json + |> Yojson.Basic.pretty_to_string + |> print_endline) diff --git a/ppx/test/errors.t/run.t b/ppx/test/errors.t/run.t new file mode 100644 index 0000000..a36d532 --- /dev/null +++ b/ppx/test/errors.t/run.t @@ -0,0 +1,40 @@ + $ dune build ./prettify.exe +Uncomment to debug +$ ocamlopt -dsource _build/default/prettify.pp.ml + $ dune exec ./prettify.exe -- ok.json + { + "a": [ "Foo" ], + "foo": [ [ "A" ], [ "Foo" ], [ "B", 123 ], [ "C", 234, "hello" ] ], + "b": "where are you ?", + "c": [ 123, 234, 345 ], + "d": [ 123, [ 1.2, 2.3, 2.4 ], "i am here" ] + } + $ dune exec ./prettify.exe -- tag_as_string.json + Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected ["A"] or ["Foo"] or ["B", _] or ["C", _, _] or ["D", { _ }] but got "A"|}) + [2] + $ dune exec ./prettify.exe -- wrong_core_type.json + Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected int but got string: "i am a string"|}) + [2] + $ dune exec ./prettify.exe -- wrong_core_type_wide.json + Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected int but got string: "i am a v ... "|}) + [2] + $ dune exec ./prettify.exe -- deep_culprit.json + Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected string but got object: {"a": _, "foo": _, "b": _, "c": _, "d": _}|}) + [2] + $ dune exec ./prettify.exe -- wide_culprit.json + Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected string but got array: [123, 234, 345, 123, 234, 345, 123, 234, ...]|}) + [2] + $ dune exec ./prettify.exe -- missing_field.json + Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected field "b" but got {"a": _, "foo": _, "c": _, "d": _}|}) + [2] + $ dune exec ./prettify.exe -- unknown_tag.json + Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected ["A"] or ["Foo"] or ["B", _] or ["C", _, _] or ["D", { _ }] but got ["Bar"]|}) + [2] + $ dune exec ./prettify.exe -- wrong_tag_payload.json + Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected ["A"] or ["Foo"] or ["B", _] or ["C", _, _] or ["D", { _ }] but got ["B", 123, "booh"]|}) + [2] + $ dune exec ./prettify.exe -- extra_field.json + Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|did not expect field "bar" but got {"a": _, "foo": _, "bar": _, "b": _, "c": _, "d": _}|}) + [2] + + diff --git a/ppx/test/errors.t/tag_as_string.json b/ppx/test/errors.t/tag_as_string.json new file mode 100644 index 0000000..f3af4f5 --- /dev/null +++ b/ppx/test/errors.t/tag_as_string.json @@ -0,0 +1,11 @@ +{ + "a": ["Foo"], + "foo": ["A", + "Foo", + ["B", 123], + ["C", 234, "hello"] + ], + "b": "where are you ?", + "c": [123, 234, 345], + "d": [123, [1.2, 2.3, 2.4], "i am here"] +} \ No newline at end of file diff --git a/ppx/test/errors.t/unknown_tag.json b/ppx/test/errors.t/unknown_tag.json new file mode 100644 index 0000000..47cb5e2 --- /dev/null +++ b/ppx/test/errors.t/unknown_tag.json @@ -0,0 +1,11 @@ +{ + "a": ["Foo"], + "foo": [["Bar"], + ["Foo"], + ["B", 123], + ["C", 234, "hello"] + ], + "b": "where are you ?", + "c": [123, 234, 345], + "d": [123, [1.2, 2.3, 2.4], "i am here"] +} \ No newline at end of file diff --git a/ppx/test/errors.t/wide_culprit.json b/ppx/test/errors.t/wide_culprit.json new file mode 100644 index 0000000..77e47e6 --- /dev/null +++ b/ppx/test/errors.t/wide_culprit.json @@ -0,0 +1,11 @@ +{ + "a": ["Foo"], + "foo": [["A"], + ["Foo"], + ["B", 123], + ["C", 234, "hello"] + ], + "b": [123, 234, 345, 123, 234, 345, 123, 234, 345, 123, 234, 345, 123, 234, 345], + "c": [123, 234, 345], + "d": [123, [1.2, 2.3, 2.4], "i am here"] +} \ No newline at end of file diff --git a/ppx/test/errors.t/wrong_core_type.json b/ppx/test/errors.t/wrong_core_type.json new file mode 100644 index 0000000..2ac8436 --- /dev/null +++ b/ppx/test/errors.t/wrong_core_type.json @@ -0,0 +1,11 @@ +{ + "a": ["Foo"], + "foo": [["A"], + ["Foo"], + ["B", "i am a string"], + ["C", 234, "hello"] + ], + "b": "where are you ?", + "c": [123, 234, 345], + "d": [123, [1.2, 2.3, 2.4], "i am here"] +} \ No newline at end of file diff --git a/ppx/test/errors.t/wrong_core_type_wide.json b/ppx/test/errors.t/wrong_core_type_wide.json new file mode 100644 index 0000000..2609871 --- /dev/null +++ b/ppx/test/errors.t/wrong_core_type_wide.json @@ -0,0 +1,11 @@ +{ + "a": ["Foo"], + "foo": [["A"], + ["Foo"], + ["B", "i am a very very very very long string"], + ["C", 234, "hello"] + ], + "b": "where are you ?", + "c": [123, 234, 345], + "d": [123, [1.2, 2.3, 2.4], "i am here"] +} \ No newline at end of file diff --git a/ppx/test/errors.t/wrong_tag_payload.json b/ppx/test/errors.t/wrong_tag_payload.json new file mode 100644 index 0000000..b1d0f69 --- /dev/null +++ b/ppx/test/errors.t/wrong_tag_payload.json @@ -0,0 +1,11 @@ +{ + "a": ["Foo"], + "foo": [["A"], + ["Foo"], + ["B", 123, "booh"], + ["C", 234, "hello"] + ], + "b": "where are you ?", + "c": [123, 234, 345], + "d": [123, [1.2, 2.3, 2.4], "i am here"] +} \ No newline at end of file diff --git a/ppx/test/poly.t b/ppx/test/poly.t index 7944a84..ad3726f 100644 --- a/ppx/test/poly.t +++ b/ppx/test/poly.t @@ -65,7 +65,7 @@ We can alias poly varaints: then (if Stdlib.(<>) len 1 then - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "expected a JSON array of length 1"; `A) else @@ -73,7 +73,7 @@ We can alias poly varaints: then (if Stdlib.(<>) len 1 then - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "expected a JSON array of length 1"; `B) else @@ -82,13 +82,13 @@ We can alias poly varaints: (Ppx_deriving_json_runtime.Unexpected_variant "unexpected variant"))) else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array with element being a string") else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array") else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" : Js.Json.t -> t) let _ = of_json [@@@ocaml.warning "-39-11-27"] @@ -206,7 +206,7 @@ We can extend aliased polyvariants: then (if Stdlib.(<>) len 1 then - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "expected a JSON array of length 1"; `A) else @@ -214,7 +214,7 @@ We can extend aliased polyvariants: then (if Stdlib.(<>) len 1 then - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "expected a JSON array of length 1"; `B) else @@ -223,13 +223,13 @@ We can extend aliased polyvariants: (Ppx_deriving_json_runtime.Unexpected_variant "unexpected variant"))) else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array with element being a string") else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array") else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" : Js.Json.t -> t) let _ = of_json [@@@ocaml.warning "-39-11-27"] @@ -266,8 +266,8 @@ 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"; + Ppx_deriving_json_runtime.of_json_msg_error + ~json:x "expected a JSON array of length 1"; `C) else raise @@ -275,13 +275,13 @@ We can extend aliased polyvariants: (Ppx_deriving_json_runtime.Unexpected_variant "unexpected variant"))) else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array with element being a string") else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array") else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" : Js.Json.t -> u) let _ = u_of_json [@@@ocaml.warning "-39-11-27"] @@ -421,16 +421,16 @@ 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"; + Ppx_deriving_json_runtime.of_json_msg_error + ~json:x "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"; + Ppx_deriving_json_runtime.of_json_msg_error + ~json:x "expected a JSON array of length 1"; `B) else raise @@ -438,13 +438,13 @@ We can extend poly variants which are placed behind signatures: (Ppx_deriving_json_runtime.Unexpected_variant "unexpected variant"))) else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array with element being a string") else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array") else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" : Js.Json.t -> t) let _ = of_json [@@@ocaml.warning "-39-11-27"] @@ -482,8 +482,8 @@ 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"; + Ppx_deriving_json_runtime.of_json_msg_error + ~json:x "expected a JSON array of length 1"; `C) else raise @@ -491,13 +491,13 @@ We can extend poly variants which are placed behind signatures: (Ppx_deriving_json_runtime.Unexpected_variant "unexpected variant"))) else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array with element being a string") else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array") else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" : Js.Json.t -> u) let _ = u_of_json [@@@ocaml.warning "-39-11-27"] diff --git a/ppx/test/ppx_deriving_json_js.e2e.t b/ppx/test/ppx_deriving_json_js.e2e.t index dbf65be..229981f 100644 --- a/ppx/test/ppx_deriving_json_js.e2e.t +++ b/ppx/test/ppx_deriving_json_js.e2e.t @@ -1,5 +1,5 @@ - $ echo '(lang dune 3.11) + $ echo '(lang dune 3.11) > (using melange 0.1)' > dune-project $ echo ' diff --git a/ppx/test/ppx_deriving_json_js.t b/ppx/test/ppx_deriving_json_js.t index e51689f..299e601 100644 --- a/ppx/test/ppx_deriving_json_js.t +++ b/ppx/test/ppx_deriving_json_js.t @@ -52,15 +52,15 @@ [@@@ocaml.warning "-39-11-27"] - let rec param_of_json a_of_json = - (fun x -> a_of_json x : Js.Json.t -> 'a param) + let rec param_of_json a_of_json : Js.Json.t -> 'a param = + fun x -> a_of_json x let _ = param_of_json [@@@ocaml.warning "-39-11-27"] - let rec param_to_json a_to_json = - (fun x -> a_to_json x : 'a param -> Js.Json.t) + let rec param_to_json a_to_json : 'a param -> Js.Json.t = + fun x -> a_to_json x let _ = param_to_json end [@@ocaml.doc "@inline"] [@@merlin.hide] @@ -135,7 +135,7 @@ ( 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 + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a JSON array of length 2" : Js.Json.t -> tuple) @@ -175,7 +175,8 @@ (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error "expected a JSON object"; + Ppx_deriving_json_runtime.of_json_msg_error + "expected a JSON object"; let fs = (Obj.magic x : < name : Js.Json.t Js.undefined @@ -187,14 +188,14 @@ (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\""); + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected field \"name\" to be present"); 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\""); + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected field \"age\" to be present"); } : Js.Json.t -> record) @@ -240,7 +241,8 @@ (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error "expected a JSON object"; + Ppx_deriving_json_runtime.of_json_msg_error + "expected a JSON object"; let fs = (Obj.magic x : < my_name : Js.Json.t Js.undefined @@ -252,8 +254,8 @@ (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\""); + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected field \"my_name\" to be present"); age = (match Js.Undefined.toOption fs##my_age with | Stdlib.Option.Some v -> int_of_json v @@ -302,7 +304,8 @@ (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error "expected a JSON object"; + Ppx_deriving_json_runtime.of_json_msg_error + "expected a JSON object"; let fs = (Obj.magic x : < k : Js.Json.t Js.undefined > Js.t) in { k = @@ -348,17 +351,17 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "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 + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "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 + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "expected a JSON array of length 2"; let fs = Js.Array.unsafe_get array 1 in if @@ -372,7 +375,7 @@ (Obj.magic fs : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_msg_error "expected a JSON object"; let fs = (Obj.magic fs : < name : Js.Json.t Js.undefined > Js.t) @@ -383,19 +386,20 @@ (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\""); + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected field \"name\" to be present"); }) - else Ppx_deriving_json_runtime.of_json_error "invalid JSON" + else + Ppx_deriving_json_runtime.of_json_msg_error "invalid JSON" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" : Js.Json.t -> sum) @@ -444,21 +448,22 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "S2" then ( if Stdlib.( <> ) len 3 then - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "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 + Ppx_deriving_json_runtime.of_json_msg_error "invalid JSON" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" : Js.Json.t -> sum2) @@ -503,7 +508,7 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "C" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "expected a JSON array of length 1"; `C) else @@ -512,14 +517,14 @@ (Ppx_deriving_json_runtime.Unexpected_variant "unexpected variant")) else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" : Js.Json.t -> other) @@ -554,12 +559,12 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "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 + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "expected a JSON array of length 2"; `B (int_of_json (Js.Array.unsafe_get array 1))) else @@ -573,14 +578,14 @@ (Ppx_deriving_json_runtime.Unexpected_variant "unexpected variant")) else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" : Js.Json.t -> poly) @@ -622,7 +627,7 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "P2" then ( if Stdlib.( <> ) len 3 then - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "expected a JSON array of length 3"; `P2 ( int_of_json (Js.Array.unsafe_get array 1), @@ -633,14 +638,14 @@ (Ppx_deriving_json_runtime.Unexpected_variant "unexpected variant")) else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" : Js.Json.t -> poly2) @@ -674,48 +679,45 @@ [@@@ocaml.warning "-39-11-27"] - let rec c_of_json a_of_json = - (fun x -> - if Js.Array.isArray x then - let array = (Obj.magic x : Js.Json.t array) in - let len = Js.Array.length array in - if Stdlib.( > ) len 0 then - let tag = Js.Array.unsafe_get array 0 in - if Stdlib.( = ) (Js.typeof tag) "string" then - let tag = (Obj.magic tag : string) in - if Stdlib.( = ) tag "C" then ( - if Stdlib.( <> ) len 2 then - Ppx_deriving_json_runtime.of_json_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")) - 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 -> 'a c) + let rec c_of_json a_of_json : Js.Json.t -> 'a c = + fun x -> + if Js.Array.isArray x then + let array = (Obj.magic x : Js.Json.t array) in + let len = Js.Array.length array in + if Stdlib.( > ) len 0 then + let tag = Js.Array.unsafe_get array 0 in + if Stdlib.( = ) (Js.typeof tag) "string" then + let tag = (Obj.magic tag : string) in + if Stdlib.( = ) tag "C" then ( + if Stdlib.( <> ) len 2 then + Ppx_deriving_json_runtime.of_json_msg_error ~json:x + "expected a JSON array of length 2"; + `C (a_of_json (Js.Array.unsafe_get array 1))) + else + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) + else + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected a non empty JSON array with element being a string" + else + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected a non empty JSON array" + else + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected a non empty JSON array" let _ = c_of_json [@@@ocaml.warning "-39-11-27"] - let rec c_to_json a_to_json = - (fun x -> - match x with - | `C x_0 -> - (Obj.magic [| (Obj.magic "C" : Js.Json.t); a_to_json x_0 |] - : Js.Json.t) - : 'a c -> Js.Json.t) + let rec c_to_json a_to_json : 'a c -> Js.Json.t = + fun x -> + match x with + | `C x_0 -> + (Obj.magic [| (Obj.magic "C" : Js.Json.t); a_to_json x_0 |] + : Js.Json.t) let _ = c_to_json end [@@ocaml.doc "@inline"] [@@merlin.hide] @@ -741,24 +743,25 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "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 + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "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 + Ppx_deriving_json_runtime.of_json_msg_error "invalid JSON" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" : Js.Json.t -> recur) @@ -800,12 +803,12 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "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 + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "expected a JSON array of length 2"; `Fix (polyrecur_of_json (Js.Array.unsafe_get array 1))) else @@ -814,14 +817,14 @@ (Ppx_deriving_json_runtime.Unexpected_variant "unexpected variant")) else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" : Js.Json.t -> polyrecur) @@ -863,24 +866,25 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "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 + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "expected a JSON array of length 1"; B) - else Ppx_deriving_json_runtime.of_json_error "invalid JSON" + else + Ppx_deriving_json_runtime.of_json_msg_error "invalid JSON" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" : Js.Json.t -> evar) @@ -921,12 +925,12 @@ 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 + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "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 + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "expected a JSON array of length 1"; `b) else @@ -935,14 +939,14 @@ (Ppx_deriving_json_runtime.Unexpected_variant "unexpected variant")) else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" : Js.Json.t -> epoly) @@ -972,52 +976,49 @@ [@@@ocaml.warning "-39-11-27"] - let rec p2_of_json a_of_json b_of_json = - (fun x -> - if Js.Array.isArray x then - let array = (Obj.magic x : Js.Json.t array) in - let len = Js.Array.length array in - if Stdlib.( > ) len 0 then - let tag = Js.Array.unsafe_get array 0 in - if Stdlib.( = ) (Js.typeof tag) "string" then - let tag = (Obj.magic tag : string) in - if Stdlib.( = ) tag "A" then ( - if Stdlib.( <> ) len 2 then - Ppx_deriving_json_runtime.of_json_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"; - B (b_of_json (Js.Array.unsafe_get array 1))) - else Ppx_deriving_json_runtime.of_json_error "invalid JSON" - 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 -> ('a, 'b) p2) + let rec p2_of_json a_of_json b_of_json : Js.Json.t -> ('a, 'b) p2 = + fun x -> + if Js.Array.isArray x then + let array = (Obj.magic x : Js.Json.t array) in + let len = Js.Array.length array in + if Stdlib.( > ) len 0 then + let tag = Js.Array.unsafe_get array 0 in + if Stdlib.( = ) (Js.typeof tag) "string" then + let tag = (Obj.magic tag : string) in + if Stdlib.( = ) tag "A" then ( + if Stdlib.( <> ) len 2 then + Ppx_deriving_json_runtime.of_json_msg_error ~json:x + "expected a JSON array of length 2"; + A (a_of_json (Js.Array.unsafe_get array 1))) + else if Stdlib.( = ) tag "B" then ( + if Stdlib.( <> ) len 2 then + Ppx_deriving_json_runtime.of_json_msg_error ~json:x + "expected a JSON array of length 2"; + B (b_of_json (Js.Array.unsafe_get array 1))) + else Ppx_deriving_json_runtime.of_json_msg_error "invalid JSON" + else + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected a non empty JSON array with element being a string" + else + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected a non empty JSON array" + else + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected a non empty JSON array" let _ = p2_of_json [@@@ocaml.warning "-39-11-27"] - let rec p2_to_json a_to_json b_to_json = - (fun x -> - match x with - | A x_0 -> - (Obj.magic [| (Obj.magic "A" : Js.Json.t); a_to_json x_0 |] - : Js.Json.t) - | B x_0 -> - (Obj.magic [| (Obj.magic "B" : Js.Json.t); b_to_json x_0 |] - : Js.Json.t) - : ('a, 'b) p2 -> Js.Json.t) + let rec p2_to_json a_to_json b_to_json : ('a, 'b) p2 -> Js.Json.t = + fun x -> + match x with + | A x_0 -> + (Obj.magic [| (Obj.magic "A" : Js.Json.t); a_to_json x_0 |] + : Js.Json.t) + | B x_0 -> + (Obj.magic [| (Obj.magic "B" : Js.Json.t); b_to_json x_0 |] + : Js.Json.t) let _ = p2_to_json end [@@ocaml.doc "@inline"] [@@merlin.hide] @@ -1044,15 +1045,16 @@ (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error "expected a JSON object"; + Ppx_deriving_json_runtime.of_json_msg_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\""); + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected field \"a\" to be present"); } : Js.Json.t -> allow_extra_fields) @@ -1092,7 +1094,7 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 2 then - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_msg_error ~json:x "expected a JSON array of length 2"; let fs = Js.Array.unsafe_get array 1 in if @@ -1106,7 +1108,7 @@ (Obj.magic fs : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_msg_error "expected a JSON object"; let fs = (Obj.magic fs : < a : Js.Json.t Js.undefined > Js.t) @@ -1117,19 +1119,20 @@ (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\""); + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected field \"a\" to be present"); }) - else Ppx_deriving_json_runtime.of_json_error "invalid JSON" + else + Ppx_deriving_json_runtime.of_json_msg_error "invalid JSON" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" else - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a non empty JSON array" : Js.Json.t -> allow_extra_fields2) @@ -1177,7 +1180,8 @@ (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error "expected a JSON object"; + Ppx_deriving_json_runtime.of_json_msg_error + "expected a JSON object"; let fs = (Obj.magic x : < a : Js.Json.t Js.undefined @@ -1189,8 +1193,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\""); + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected field \"a\" to be present"); 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_native.e2e.t b/ppx/test/ppx_deriving_json_native.e2e.t index d9cde85..db1dcd6 100644 --- a/ppx/test/ppx_deriving_json_native.e2e.t +++ b/ppx/test/ppx_deriving_json_native.e2e.t @@ -3,7 +3,7 @@ > (implicit_transitive_deps false) > ' >> dune-project $ echo ' - > (executable + > (executable > (name main) > (flags :standard -w -37-69 -open Ppx_deriving_json_runtime.Primitives) > (preprocess (pps melange-json-native.ppx)))' > dune diff --git a/ppx/test/ppx_deriving_json_native.t b/ppx/test/ppx_deriving_json_native.t index 45b991d..cdabb25 100644 --- a/ppx/test/ppx_deriving_json_native.t +++ b/ppx/test/ppx_deriving_json_native.t @@ -52,15 +52,15 @@ [@@@ocaml.warning "-39-11-27"] - let rec param_of_json a_of_json = - (fun x -> a_of_json x : Yojson.Basic.t -> 'a param) + let rec param_of_json a_of_json : Yojson.Basic.t -> 'a param = + fun x -> a_of_json x let _ = param_of_json [@@@ocaml.warning "-39-11-27"] - let rec param_to_json a_to_json = - (fun x -> a_to_json x : 'a param -> Yojson.Basic.t) + let rec param_to_json a_to_json : 'a param -> Yojson.Basic.t = + fun x -> a_to_json x let _ = param_to_json end [@@ocaml.doc "@inline"] [@@merlin.hide] @@ -128,7 +128,7 @@ 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 + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a JSON array of length 2" : Yojson.Basic.t -> tuple) @@ -169,8 +169,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)); + Ppx_deriving_json_runtime.of_json_error ~json:x + (Stdlib.Printf.sprintf + {|did not expect field "%s"|} name)); iter fs in iter fs; @@ -179,17 +180,17 @@ (match Stdlib.( ! ) x_name with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"name\""); + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected 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\""); + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected field \"age\""); } | _ -> - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a JSON object" : Yojson.Basic.t -> record) @@ -241,8 +242,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)); + Ppx_deriving_json_runtime.of_json_error ~json:x + (Stdlib.Printf.sprintf + {|did not expect field "%s"|} name)); iter fs in iter fs; @@ -251,15 +253,15 @@ (match Stdlib.( ! ) x_name with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"my_name\""); + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected 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 + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a JSON object" : Yojson.Basic.t -> record_aliased) @@ -308,8 +310,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)); + Ppx_deriving_json_runtime.of_json_error ~json:x + (Stdlib.Printf.sprintf + {|did not expect field "%s"|} name)); iter fs in iter fs; @@ -320,7 +323,7 @@ | Stdlib.Option.None -> Stdlib.Option.None); } | _ -> - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a JSON object" : Yojson.Basic.t -> record_opt) @@ -367,8 +370,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)); + Ppx_deriving_json_runtime.of_json_error ~json:x + (Stdlib.Printf.sprintf + {|did not expect field "%s"|} name)); iter fs in iter fs; @@ -378,14 +382,12 @@ (match Stdlib.( ! ) x_name with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"name\""); + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected field \"name\""); } | _ -> - raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected [\"A\"] or [\"B\", _] or [\"C\", { _ }]" : Yojson.Basic.t -> sum) let _ = sum_of_json @@ -429,10 +431,8 @@ | `List [ `String "S2"; x_0; x_1 ] -> 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")) + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected [\"S2\", _, _]" : Yojson.Basic.t -> sum2) let _ = sum2_of_json @@ -566,25 +566,22 @@ [@@@ocaml.warning "-39-11-27"] - let rec c_of_json a_of_json = - (fun x -> - match x with - | `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")) - : Yojson.Basic.t -> 'a c) + let rec c_of_json a_of_json : Yojson.Basic.t -> 'a c = + fun x -> + match x with + | `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")) let _ = c_of_json [@@@ocaml.warning "-39-11-27"] - let rec c_to_json a_to_json = - (fun x -> - match x with `C x_0 -> `List [ `String "C"; a_to_json x_0 ] - : 'a c -> Yojson.Basic.t) + let rec c_to_json a_to_json : 'a c -> Yojson.Basic.t = + fun x -> match x with `C x_0 -> `List [ `String "C"; a_to_json x_0 ] let _ = c_to_json end [@@ocaml.doc "@inline"] [@@merlin.hide] @@ -605,10 +602,8 @@ | `List (`String "A" :: []) -> A | `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")) + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected [\"A\"] or [\"Fix\", _]" : Yojson.Basic.t -> recur) let _ = recur_of_json @@ -677,10 +672,8 @@ | `List (`String "A" :: []) -> A | `List (`String "b_aliased" :: []) -> B | _ -> - raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected [\"A\"] or [\"B\"]" : Yojson.Basic.t -> evar) let _ = evar_of_json @@ -743,28 +736,24 @@ [@@@ocaml.warning "-39-11-27"] - let rec p2_of_json a_of_json b_of_json = - (fun x -> - 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) - | _ -> - raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) - : Yojson.Basic.t -> ('a, 'b) p2) + let rec p2_of_json a_of_json b_of_json : Yojson.Basic.t -> ('a, 'b) p2 = + fun x -> + 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 ~json:x + "expected [\"A\", _] or [\"B\", _]" let _ = p2_of_json [@@@ocaml.warning "-39-11-27"] - let rec p2_to_json a_to_json b_to_json = - (fun x -> - match x with - | A x_0 -> `List [ `String "A"; a_to_json x_0 ] - | B x_0 -> `List [ `String "B"; b_to_json x_0 ] - : ('a, 'b) p2 -> Yojson.Basic.t) + let rec p2_to_json a_to_json b_to_json : ('a, 'b) p2 -> Yojson.Basic.t = + fun x -> + match x with + | A x_0 -> `List [ `String "A"; a_to_json x_0 ] + | B x_0 -> `List [ `String "B"; b_to_json x_0 ] let _ = p2_to_json end [@@ocaml.doc "@inline"] [@@merlin.hide] @@ -799,11 +788,11 @@ (match Stdlib.( ! ) x_a with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"a\""); + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected field \"a\""); } | _ -> - Ppx_deriving_json_runtime.of_json_error + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a JSON object" : Yojson.Basic.t -> allow_extra_fields) @@ -855,14 +844,12 @@ (match Stdlib.( ! ) x_a with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"a\""); + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected field \"a\""); } | _ -> - raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected [\"A\", { _ }]" : Yojson.Basic.t -> allow_extra_fields2) let _ = allow_extra_fields2_of_json @@ -915,8 +902,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)); + Ppx_deriving_json_runtime.of_json_error ~json:x + (Stdlib.Printf.sprintf + {|did not expect field "%s"|} name)); iter fs in iter fs; @@ -925,15 +913,15 @@ (match Stdlib.( ! ) x_a with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"a\""); + Ppx_deriving_json_runtime.of_json_error ~json:x + "expected 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 + Ppx_deriving_json_runtime.of_json_error ~json:x "expected a JSON object" : Yojson.Basic.t -> drop_default_option)