From 23a24664a18d8e7c22d641dc317ac0b1fe0d7e4c Mon Sep 17 00:00:00 2001 From: Javier Chavarri Date: Thu, 21 Nov 2024 18:35:04 +0000 Subject: [PATCH] add test that shows orphan tag --- ppx/test/ppx_deriving_json_js.t | 170 ++++++++++++++++++++++++++++ ppx/test/ppx_deriving_json_native.t | 106 +++++++++++++++++ 2 files changed, 276 insertions(+) diff --git a/ppx/test/ppx_deriving_json_js.t b/ppx/test/ppx_deriving_json_js.t index 3745e1c..67025a8 100644 --- a/ppx/test/ppx_deriving_json_js.t +++ b/ppx/test/ppx_deriving_json_js.t @@ -1239,3 +1239,173 @@ let _ = drop_default_option_to_json end [@@ocaml.doc "@inline"] [@@merlin.hide] + + $ cat <<"EOF" | run + > type one = [ `C ] [@@deriving json] type other = [ `C ] [@@deriving json] type poly = [ one | other ] [@@deriving json] + > EOF + type one = [ `C ] [@@deriving json] + + include struct + let _ = fun (_ : one) -> () + + [@@@ocaml.warning "-39-11-27"] + + let rec one_of_json_poly = + (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 1 then + Ppx_deriving_json_runtime.of_json_error + "expected a JSON array of length 1"; + Some `C) + else None + 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 -> one option) + + and one_of_json = + (fun x -> + match one_of_json_poly x with + | Some x -> x + | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" + : Js.Json.t -> one) + + let _ = one_of_json_poly + and _ = one_of_json + + [@@@ocaml.warning "-39-11-27"] + + let rec one_to_json = + (fun x -> + match x with + | `C -> (Obj.magic [| (Obj.magic "C" : Js.Json.t) |] : Js.Json.t) + : one -> Js.Json.t) + + let _ = one_to_json + end [@@ocaml.doc "@inline"] [@@merlin.hide] + + type other = [ `C ] [@@deriving json] + + include struct + let _ = fun (_ : other) -> () + + [@@@ocaml.warning "-39-11-27"] + + let rec other_of_json_poly = + (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 1 then + Ppx_deriving_json_runtime.of_json_error + "expected a JSON array of length 1"; + Some `C) + else None + 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 -> other option) + + and other_of_json = + (fun x -> + match other_of_json_poly x with + | Some x -> x + | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" + : Js.Json.t -> other) + + let _ = other_of_json_poly + and _ = other_of_json + + [@@@ocaml.warning "-39-11-27"] + + let rec other_to_json = + (fun x -> + match x with + | `C -> (Obj.magic [| (Obj.magic "C" : Js.Json.t) |] : Js.Json.t) + : other -> Js.Json.t) + + let _ = other_to_json + end [@@ocaml.doc "@inline"] [@@merlin.hide] + + type poly = [ one | other ] [@@deriving json] + + include struct + let _ = fun (_ : poly) -> () + + [@@@ocaml.warning "-39-11-27"] + + let rec poly_of_json_poly = + (fun x -> + if Js.Array.isArray x then + let array = (Obj.magic x : Js.Json.t array) in + let len = Js.Array.length array in + if Stdlib.( > ) len 0 then + let tag = Js.Array.unsafe_get array 0 in + if Stdlib.( = ) (Js.typeof tag) "string" then + let tag = (Obj.magic tag : string) in + match one_of_json_poly x with + | Some x -> (Some x :> [ one | other ] option) + | None -> ( + match other_of_json_poly x with + | Some x -> (Some x :> [ one | other ] option) + | None -> None) + 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 -> poly option) + + and poly_of_json = + (fun x -> + match poly_of_json_poly x with + | Some x -> x + | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" + : Js.Json.t -> poly) + + let _ = poly_of_json_poly + and _ = poly_of_json + + [@@@ocaml.warning "-39-11-27"] + + let rec poly_to_json = + (fun x -> + match x with + | #one as x -> one_to_json x + | #other as x -> other_to_json x + : poly -> Js.Json.t) + + let _ = poly_to_json + end [@@ocaml.doc "@inline"] [@@merlin.hide] + diff --git a/ppx/test/ppx_deriving_json_native.t b/ppx/test/ppx_deriving_json_native.t index 139c7c3..b177a3a 100644 --- a/ppx/test/ppx_deriving_json_native.t +++ b/ppx/test/ppx_deriving_json_native.t @@ -951,3 +951,109 @@ let _ = drop_default_option_to_json end [@@ocaml.doc "@inline"] [@@merlin.hide] + + $ cat <<"EOF" | run + > type one = [ `C ] [@@deriving json] type other = [ `C ] [@@deriving json] type poly = [ one | other ] [@@deriving json] + > EOF + type one = [ `C ] [@@deriving json] + + include struct + let _ = fun (_ : one) -> () + + [@@@ocaml.warning "-39-11-27"] + + let rec one_of_json_poly = + (fun x -> + match x with `List (`String "C" :: []) -> Some `C | x -> None + : Yojson.Basic.t -> one option) + + and one_of_json = + (fun x -> + match one_of_json_poly x with + | Some x -> x + | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" + : Yojson.Basic.t -> one) + + let _ = one_of_json_poly + and _ = one_of_json + + [@@@ocaml.warning "-39-11-27"] + + let rec one_to_json = + (fun x -> match x with `C -> `List [ `String "C" ] + : one -> Yojson.Basic.t) + + let _ = one_to_json + end [@@ocaml.doc "@inline"] [@@merlin.hide] + + type other = [ `C ] [@@deriving json] + + include struct + let _ = fun (_ : other) -> () + + [@@@ocaml.warning "-39-11-27"] + + let rec other_of_json_poly = + (fun x -> + match x with `List (`String "C" :: []) -> Some `C | x -> None + : Yojson.Basic.t -> other option) + + and other_of_json = + (fun x -> + match other_of_json_poly x with + | Some x -> x + | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" + : Yojson.Basic.t -> other) + + let _ = other_of_json_poly + and _ = other_of_json + + [@@@ocaml.warning "-39-11-27"] + + let rec other_to_json = + (fun x -> match x with `C -> `List [ `String "C" ] + : other -> Yojson.Basic.t) + + let _ = other_to_json + end [@@ocaml.doc "@inline"] [@@merlin.hide] + + type poly = [ one | other ] [@@deriving json] + + include struct + let _ = fun (_ : poly) -> () + + [@@@ocaml.warning "-39-11-27"] + + let rec poly_of_json_poly = + (fun x -> + match x with + | x -> ( + match other_of_json_poly x with + | Some x -> (Some x :> [ one | other ] option) + | None -> ( + match one_of_json_poly x with + | Some x -> (Some x :> [ one | other ] option) + | None -> None)) + : Yojson.Basic.t -> poly option) + + and poly_of_json = + (fun x -> + match poly_of_json_poly x with + | Some x -> x + | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" + : Yojson.Basic.t -> poly) + + let _ = poly_of_json_poly + and _ = poly_of_json + + [@@@ocaml.warning "-39-11-27"] + + let rec poly_to_json = + (fun x -> + match x with + | #one as x -> one_to_json x + | #other as x -> other_to_json x + : poly -> Yojson.Basic.t) + + let _ = poly_to_json + end [@@ocaml.doc "@inline"] [@@merlin.hide]