Skip to content

Revert "Fix error message for @@compact_variants" #90

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
pedrobslisboa merged 1 commit into from
Jun 2, 2026
Merged

Revert "Fix error message for @@compact_variants" #90

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
82 changes: 36 additions & 46 deletions ppx/browser/ppx_deriving_json_js.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -107,8 +107,7 @@ module Of_json = struct
[%e ensure_json_object ~loc x];
[%e build_record ~loc derive t.rcd_fields x Fun.id]]

let derive_of_variant ?(is_compact_variants = false) _derive t
~allow_any_constr body x =
let derive_of_variant _derive t ~allow_any_constr ?td body x =
let loc = t.vrt_loc in
let not_array_error =
match allow_any_constr with
Expand All @@ -119,7 +118,7 @@ module Of_json = struct
"expected a non empty JSON array"]
in
let string_branch =
if is_compact_variants then
if Option.fold ~none:false ~some:is_compact_variants td then
[%expr
if Stdlib.( = ) (Js.typeof [%e x]) "string" then (
let array = (Obj.magic [||] : Js.Json.t array) in
Expand Down Expand Up @@ -171,34 +170,32 @@ module Of_json = struct
in
({ tag = tag_s; payload } : Melange_json.unknown_variant_case)]

let derive_of_variant_case ?(is_compact_variants = false) derive make c
~allow_any_constr next =
let derive_of_variant_case ?td derive make c ~allow_any_constr next =
let compact = Option.fold ~none:false ~some:is_compact_variants td in
let _ = derive in
let _ = allow_any_constr in
match c with
| Vcs_tuple (n, t) when vcs_attr_json_catch_all t.tpl_ctx -> (
| Vcs_tuple (n, t) when vcs_attr_json_catch_all t.tpl_ctx ->
let loc = n.loc in
match t.tpl_types with
| [ _ ] -> make (Some (build_unknown_variant_case_record ~loc))
| _ ->
Location.raise_errorf ~loc
"[@json.catch_all] requires exactly one argument: a record \
type with fields `tag : string` and `payload : \
Melange_json.t list option` (typically \
[Melange_json.unknown_variant_case])")
| Vcs_record (_n, t) when vcs_attr_json_catch_all t.rcd_ctx -> (
(match t.tpl_types with
| [ _ ] -> make (Some (build_unknown_variant_case_record ~loc))
| _ ->
Location.raise_errorf ~loc
"[@json.catch_all] requires exactly one argument: a record \
type with fields `tag : string` and \
`payload : Melange_json.t list option` (typically \
[Melange_json.unknown_variant_case])")
| Vcs_record (_n, t) when vcs_attr_json_catch_all t.rcd_ctx ->
let loc = t.rcd_loc in
match t.rcd_fields with
| [
{ pld_name = { txt = "tag"; _ }; _ };
{ pld_name = { txt = "payload"; _ }; _ };
] ->
make (Some (build_unknown_variant_case_record ~loc))
| _ ->
Location.raise_errorf ~loc
"[@json.catch_all] inline record must have exactly two \
fields named `tag` and `payload` (in that order), with \
types `string` and `Melange_json.t list option`")
(match t.rcd_fields with
| [ { pld_name = { txt = "tag"; _ }; _ };
{ pld_name = { txt = "payload"; _ }; _ } ] ->
make (Some (build_unknown_variant_case_record ~loc))
| _ ->
Location.raise_errorf ~loc
"[@json.catch_all] inline record must have exactly two \
fields named `tag` and `payload` (in that order), with \
types `string` and `Melange_json.t list option`")
| Vcs_record (n, r) ->
let loc = n.loc in
let n = Option.value ~default:n (vcs_attr_json_name r.rcd_ctx) in
Expand All @@ -219,7 +216,7 @@ module Of_json = struct
let loc = n.loc in
let n = Option.value ~default:n (vcs_attr_json_name t.tpl_ctx) in
let arity = List.length t.tpl_types in
if is_compact_variants && arity = 0 then
if compact && arity = 0 then
[%expr
if Stdlib.( = ) tag [%e estring ~loc:n.loc n.txt] then
[%e make None]
Expand Down Expand Up @@ -289,7 +286,8 @@ module To_json = struct
let record = pexp_record ~loc fs None in
as_json ~loc [%expr [%mel.obj [%e record]]]

let derive_of_variant_case ?(is_compact_variants = false) derive c es =
let derive_of_variant_case ?td derive c es =
let compact = Option.fold ~none:false ~some:is_compact_variants td in
match c with
| Vcs_tuple (n, t) when vcs_attr_json_catch_all t.tpl_ctx -> (
let loc = n.loc in
Expand All @@ -305,45 +303,37 @@ module To_json = struct
in
let rest =
Stdlib.List.map
(fun (j : Melange_json.t) ->
(Obj.magic j : Js.Json.t))
(fun (j : Melange_json.t) -> (Obj.magic j : Js.Json.t))
xs
in
(Obj.magic
(Stdlib.Array.of_list (head :: rest)
: Js.Json.t array)
(Stdlib.Array.of_list (head :: rest) : Js.Json.t array)
: Js.Json.t)]
| _ ->
Location.raise_errorf ~loc
"[@json.catch_all] requires exactly one argument: a record \
type with fields `tag : string` and `payload : \
Melange_json.t list option` (typically \
type with fields `tag : string` and \
`payload : Melange_json.t list option` (typically \
[Melange_json.unknown_variant_case])")
| Vcs_record (_n, t) when vcs_attr_json_catch_all t.rcd_ctx -> (
let loc = t.rcd_loc in
match t.rcd_fields, es with
| ( [
{ pld_name = { txt = "tag"; _ }; _ };
{ pld_name = { txt = "payload"; _ }; _ };
],
| ( [ { pld_name = { txt = "tag"; _ }; _ };
{ pld_name = { txt = "payload"; _ }; _ } ],
[ tag_e; payload_e ] ) ->
[%expr
match [%e payload_e] with
| Stdlib.Option.None ->
(Obj.magic ([%e tag_e] : string) : Js.Json.t)
| Stdlib.Option.Some xs ->
let head =
(Obj.magic ([%e tag_e] : string) : Js.Json.t)
in
let head = (Obj.magic ([%e tag_e] : string) : Js.Json.t) in
let rest =
Stdlib.List.map
(fun (j : Melange_json.t) ->
(Obj.magic j : Js.Json.t))
(fun (j : Melange_json.t) -> (Obj.magic j : Js.Json.t))
xs
in
(Obj.magic
(Stdlib.Array.of_list (head :: rest)
: Js.Json.t array)
(Stdlib.Array.of_list (head :: rest) : Js.Json.t array)
: Js.Json.t)]
| _ ->
Location.raise_errorf ~loc
Expand All @@ -369,7 +359,7 @@ module To_json = struct
let loc = n.loc in
let n = Option.value ~default:n (vcs_attr_json_name t.tpl_ctx) in
let arity = List.length t.tpl_types in
if is_compact_variants && arity = 0 then
if compact && arity = 0 then
as_json ~loc (estring ~loc:n.loc n.txt)
else
let tag =
Expand Down
10 changes: 10 additions & 0 deletions ppx/native/common/ppx_deriving_json_common.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -101,6 +101,16 @@ let ld_attr_json_drop_default_if_json_equal =
(Attribute.declare_flag "json.drop_default_if_json_equal"
Attribute.Context.label_declaration)

let td_attr_json_compact_variants =
Attribute.get
(Attribute.declare "json.compact_variants"
Attribute.Context.type_declaration
Ast_pattern.(pstr nil)
())

let is_compact_variants td =
Option.is_some (td_attr_json_compact_variants td)

let ld_attr_default ld =
match ld_attr_json_default ld with
| Some e -> Some e
Expand Down
Loading