From 834bfe5fb20466e3f9bca36e4204ba447a9d0d2f Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Thu, 15 Aug 2024 22:30:02 -0700 Subject: [PATCH 1/7] support `[@mel.unwrap]` in `@@deriving jsProperties` --- ppx/ast_attributes.ml | 12 ++-- ppx/ast_attributes.mli | 2 +- ppx/ast_derive/ast_derive_abstract.ml | 100 +++++++++++++++++++++++--- ppx/ast_external.ml | 4 +- ppx/ast_external_mk.ml | 24 ------- ppx/ast_external_mk.mli | 3 - ppx/ast_external_process.ml | 14 ++-- ppx/ast_external_process.mli | 15 +++- 8 files changed, 119 insertions(+), 55 deletions(-) diff --git a/ppx/ast_attributes.ml b/ppx/ast_attributes.ml index 11ada12bc..4974cb731 100644 --- a/ppx/ast_attributes.ml +++ b/ppx/ast_attributes.ml @@ -407,16 +407,16 @@ let iter_process_mel_int_as attrs = attrs; !st -let has_mel_optional attrs : bool = - List.exists - ~f:(fun ({ attr_name = { txt; loc }; _ } as attr) -> +let has_mel_optional attrs : bool * attribute list = + List.fold_right + ~f:(fun ({ attr_name = { txt; loc }; _ } as attr) (acc, acc_attrs) -> match txt with | "mel.optional" | "bs.optional" | "optional" -> error_if_bs_or_non_namespaced ~loc txt; Mel_ast_invariant.mark_used_mel_attribute attr; - true - | _ -> false) - attrs + (true, acc_attrs) + | _ -> (acc, attr :: acc_attrs)) + ~init:(false, []) attrs let is_inline : attribute -> bool = fun { attr_name = { txt; loc }; _ } -> diff --git a/ppx/ast_attributes.mli b/ppx/ast_attributes.mli index fb1ae7afb..afb5cf5f5 100644 --- a/ppx/ast_attributes.mli +++ b/ppx/ast_attributes.mli @@ -57,7 +57,7 @@ val iter_process_mel_string_int_unwrap_uncurry : val iter_process_mel_string_as : attribute list -> label option val iter_process_mel_int_as : attribute list -> int option -val has_mel_optional : attribute list -> bool +val has_mel_optional : attribute list -> bool * attribute list val has_inline_payload : attribute list -> attribute option val rs_externals : attribute list -> string list -> bool diff --git a/ppx/ast_derive/ast_derive_abstract.ml b/ppx/ast_derive/ast_derive_abstract.ml index ff0b61a67..5eea1cb14 100644 --- a/ppx/ast_derive/ast_derive_abstract.ml +++ b/ppx/ast_derive/ast_derive_abstract.ml @@ -46,15 +46,38 @@ let with_deprecation ~is_deprecated attrs = | true -> deprecated_abstract :: attrs let get_pld_type pld_type ~attrs = - let is_optional = Ast_attributes.has_mel_optional attrs in + let is_optional, _ = Ast_attributes.has_mel_optional attrs in if is_optional then match pld_type.ptyp_desc with | Ptyp_constr ({ txt = Lident "option"; _ }, [ pld_type ]) -> pld_type | _ -> Location.raise_errorf ~loc:pld_type.ptyp_loc - "`[@mel.optional]' must appear on an option literal type (`_ option')" + "`[@mel.optional]' must appear on a literal option type (`_ option')" else pld_type +let exernal_arg_spec_option_labels (labels : (bool * string Asttypes.loc) list) + (ends_with_unit : bool) : + Melange_ffi.External_arg_spec.label Melange_ffi.External_arg_spec.param list + = + List.fold_right + ~f:(fun (is_option, p) arg_kinds -> + let label_name = Melange_ffi.Lam_methname.translate p.txt in + let obj_arg_label = + if is_option then + Melange_ffi.External_arg_spec.optional false label_name + else Melange_ffi.External_arg_spec.obj_label label_name + in + { + Melange_ffi.External_arg_spec.arg_type = Nothing; + arg_label = obj_arg_label; + } + :: arg_kinds) + labels + ~init: + (if ends_with_unit then + [ Melange_ffi.External_arg_spec.empty_kind Extern_unit ] + else []) + let derive_js_constructor ?(is_deprecated = false) tdcl = match tdcl.ptype_kind with | Ptype_record label_declarations -> ( @@ -62,7 +85,10 @@ let derive_js_constructor ?(is_deprecated = false) tdcl = let has_optional_field = List.exists ~f:(fun (x : label_declaration) -> - Ast_attributes.has_mel_optional x.pld_attributes) + let is_optional, _ = + Ast_attributes.has_mel_optional x.pld_attributes + in + is_optional) label_declarations in let makeType, labels = @@ -84,12 +110,27 @@ let derive_js_constructor ?(is_deprecated = false) tdcl = | None -> pld_name | Some new_name -> { pld_name with txt = new_name } in - let is_optional = Ast_attributes.has_mel_optional pld_attributes in + let is_optional, remaining_attrs = + Ast_attributes.has_mel_optional pld_attributes + in let maker = if is_optional then - let pld_type = get_pld_type ~attrs:pld_attributes pld_type in - Typ.arrow ~loc:pld_loc (Optional label_name) pld_type maker - else Typ.arrow ~loc:pld_loc (Labelled label_name) pld_type maker + let pld_type = get_pld_type pld_type ~attrs:pld_attributes in + Typ.arrow ~loc:pld_loc (Optional label_name) + { + pld_type with + ptyp_attributes = + List.append pld_type.ptyp_attributes remaining_attrs; + } + maker + else + Typ.arrow ~loc:pld_loc (Labelled label_name) + { + pld_type with + ptyp_attributes = + List.append pld_type.ptyp_attributes remaining_attrs; + } + maker in (maker, (is_optional, newLabel) :: labels)) label_declarations @@ -104,16 +145,50 @@ let derive_js_constructor ?(is_deprecated = false) tdcl = match tdcl.ptype_private with | Private -> [] | Public -> - let myPrims = - Ast_external_mk.pval_prim_of_option_labels labels has_optional_field + let prim_labels = + exernal_arg_spec_option_labels labels has_optional_field + in + let _pval_type, ffi, _pval_attributes, _no_inline_cross_module = + Ast_external_process.handle_attributes loc makeType + [ + { + attr_name = { txt = "mel.obj"; loc = Location.none }; + attr_payload = PStr []; + attr_loc = Location.none; + }; + ] + ~pval_name:"" ~prim_name:"" + in + let prim = + match ffi with + | Melange_ffi.External_ffi_types.Ffi_obj_create obj_arg_types -> + assert (List.length prim_labels = List.length obj_arg_types); + List.map2 + ~f:(fun + (label : + Melange_ffi.External_arg_spec.label + Melange_ffi.External_arg_spec.param) + (obj_arg_type : + Melange_ffi.External_arg_spec.label + Melange_ffi.External_arg_spec.param) + -> + { + Melange_ffi.External_arg_spec.arg_type = + obj_arg_type.arg_type; + arg_label = label.arg_label; + }) + prim_labels obj_arg_types + | _ -> assert false in + [ Val.mk ~loc { loc; txt = tdcl.ptype_name.txt } ~attrs: (with_deprecation ~is_deprecated [ Ast_attributes.unboxable_type_in_prim_decl ]) - ~prim:myPrims makeType; + ~prim:(Melange_ffi.External_ffi_types.ffi_obj_as_prims prim) + makeType; ]) | Ptype_abstract | Ptype_variant _ | Ptype_open -> (* Looks obvious that it does not make sense to warn *) @@ -154,7 +229,10 @@ let derive_getters_setters = in let prim = [ prim_as_name ] in let acc = - if Ast_attributes.has_mel_optional pld_attributes then + let is_optional, _ = + Ast_attributes.has_mel_optional pld_attributes + in + if is_optional then let optional_type = pld_type in Val.mk ~loc:pld_loc (if light then pld_name diff --git a/ppx/ast_external.ml b/ppx/ast_external.ml index 1134440c7..dfe23d445 100644 --- a/ppx/ast_external.ml +++ b/ppx/ast_external.ml @@ -46,7 +46,7 @@ let handleExternalInSig (self : Ast_traverse.map) (prim : value_description) no_inline_cross_module; } = Ast_external_process.handle_attributes_as_string loc pval_type - pval_attributes prim.pval_name.txt v + pval_attributes ~pval_name:prim.pval_name.txt ~prim_name:v in { @@ -78,7 +78,7 @@ let handleExternalInStru (self : Ast_traverse.map) (prim : value_description) no_inline_cross_module; } = Ast_external_process.handle_attributes_as_string loc pval_type - pval_attributes prim.pval_name.txt v + pval_attributes ~pval_name:prim.pval_name.txt ~prim_name:v in let external_result = { diff --git a/ppx/ast_external_mk.ml b/ppx/ast_external_mk.ml index f755940de..db731407d 100644 --- a/ppx/ast_external_mk.ml +++ b/ppx/ast_external_mk.ml @@ -175,30 +175,6 @@ let pval_prim_of_labels (labels : string Asttypes.loc list) = in Melange_ffi.External_ffi_types.ffi_obj_as_prims arg_kinds -let pval_prim_of_option_labels (labels : (bool * string Asttypes.loc) list) - (ends_with_unit : bool) = - let arg_kinds = - List.fold_right - ~f:(fun (is_option, p) arg_kinds -> - let label_name = Melange_ffi.Lam_methname.translate p.txt in - let obj_arg_label = - if is_option then - Melange_ffi.External_arg_spec.optional false label_name - else Melange_ffi.External_arg_spec.obj_label label_name - in - { - Melange_ffi.External_arg_spec.arg_type = Nothing; - arg_label = obj_arg_label; - } - :: arg_kinds) - labels - ~init: - (if ends_with_unit then - [ Melange_ffi.External_arg_spec.empty_kind Extern_unit ] - else []) - in - Melange_ffi.External_ffi_types.ffi_obj_as_prims arg_kinds - let record_as_js_object ~loc (label_exprs : (Longident.t Asttypes.loc * expression) list) : expression_desc = diff --git a/ppx/ast_external_mk.mli b/ppx/ast_external_mk.mli index 25306d771..61df3881c 100644 --- a/ppx/ast_external_mk.mli +++ b/ppx/ast_external_mk.mli @@ -60,9 +60,6 @@ val pval_prim_of_labels : string Asttypes.loc list -> string list {[ [%obj { x = 2; y = 1} ] ]} *) -val pval_prim_of_option_labels : - (bool * string Asttypes.loc) list -> bool -> string list - val record_as_js_object : loc:Location.t -> (Longident.t Asttypes.loc * expression) list -> diff --git a/ppx/ast_external_process.ml b/ppx/ast_external_process.ml index 27627efe3..4b4ffeb5f 100644 --- a/ppx/ast_external_process.ml +++ b/ppx/ast_external_process.ml @@ -1012,10 +1012,11 @@ let list_of_arrow (ty : core_type) : core_type * param_type list = in aux ty [] -(* Note that the passed [type_annotation] is already processed by visitor pattern before*) +(* Note that the passed [type_annotation] is already processed by visitor + pattern before *) let handle_attributes (loc : Location.t) (type_annotation : core_type) - (prim_attributes : attribute list) (pval_name : string) (prim_name : string) - : core_type * External_ffi_types.t * attributes * bool = + (prim_attributes : attribute list) ~pval_name ~prim_name : + core_type * External_ffi_types.t * attributes * bool = (* sanity check here {[ int -> int -> (int -> int -> int [@uncurry])]} It does not make sense *) @@ -1159,13 +1160,12 @@ let handle_attributes (loc : Location.t) (type_annotation : core_type) relative ) let handle_attributes_as_string (pval_loc : Location.t) (typ : core_type) - (attrs : attribute list) (pval_name : string) (prim_name : string) : - response = + (attrs : attribute list) ~pval_name ~prim_name : response = match typ.ptyp_desc with | Ptyp_constr ({ txt = Ldot (Ldot (Lident "Js", "Fn"), arity); loc }, [ fn_type ]) -> let pval_type, ffi, pval_attributes, no_inline_cross_module = - handle_attributes pval_loc fn_type attrs pval_name prim_name + handle_attributes pval_loc fn_type attrs ~pval_name ~prim_name in { pval_type = @@ -1178,7 +1178,7 @@ let handle_attributes_as_string (pval_loc : Location.t) (typ : core_type) } | _ -> let pval_type, ffi, pval_attributes, no_inline_cross_module = - handle_attributes pval_loc typ attrs pval_name prim_name + handle_attributes pval_loc typ attrs ~pval_name ~prim_name in { pval_type; diff --git a/ppx/ast_external_process.mli b/ppx/ast_external_process.mli index 5f3e791a6..3cd5bcb47 100644 --- a/ppx/ast_external_process.mli +++ b/ppx/ast_external_process.mli @@ -31,8 +31,21 @@ type response = { no_inline_cross_module : bool; } +val handle_attributes : + Location.t -> + core_type -> + attribute list -> + pval_name:string -> + prim_name:string -> + core_type * Melange_ffi.External_ffi_types.t * attributes * bool + val handle_attributes_as_string : - Location.t -> core_type -> attribute list -> string -> string -> response + Location.t -> + core_type -> + attribute list -> + pval_name:string -> + prim_name:string -> + response (** [handle_attributes_as_string loc pval_name.txt pval_type pval_attributes pval_prim] From 7760d2c61054202a6c781f4ae2a47c4238d04225 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Thu, 15 Aug 2024 22:43:42 -0700 Subject: [PATCH 2/7] remove mel.as attr after processing too --- ppx/ast_attributes.ml | 32 ++++++++++++++------------ ppx/ast_attributes.mli | 2 +- ppx/ast_derive/ast_derive_abstract.ml | 17 +++++++------- ppx/ast_derive/ast_derive_js_mapper.ml | 1 + ppx/ast_external_mk.ml | 1 + ppx/ast_external_process.ml | 1 + ppx/ast_polyvar.ml | 2 ++ 7 files changed, 32 insertions(+), 24 deletions(-) diff --git a/ppx/ast_attributes.ml b/ppx/ast_attributes.ml index 4974cb731..850dad869 100644 --- a/ppx/ast_attributes.ml +++ b/ppx/ast_attributes.ml @@ -326,23 +326,25 @@ let iter_process_mel_string_int_unwrap_uncurry attrs = attrs; !st -let iter_process_mel_string_as attrs : string option = - let st = ref None in - List.iter - ~f:(fun ({ attr_name = { txt; loc }; attr_payload = payload; _ } as attr) -> +let iter_process_mel_string_as attrs : string option * attributes = + List.fold_right + ~f:(fun + ({ attr_name = { txt; loc }; attr_payload = payload; _ } as attr) + (acc, attrs_acc) + -> match txt with - | "mel.as" | "bs.as" | "as" -> + | "mel.as" | "bs.as" | "as" -> ( error_if_bs_or_non_namespaced ~loc txt; - if !st = None then ( - match Ast_payload.is_single_string payload with - | None -> Error.err ~loc Expect_string_literal - | Some (v, _dec) -> - Mel_ast_invariant.mark_used_mel_attribute attr; - st := Some v) - else Error.err ~loc Duplicated_mel_as - | _ -> ()) - attrs; - !st + match acc with + | None -> ( + match Ast_payload.is_single_string payload with + | None -> Error.err ~loc Expect_string_literal + | Some (v, _dec) -> + Mel_ast_invariant.mark_used_mel_attribute attr; + (Some v, attrs_acc)) + | Some _ -> Error.err ~loc Duplicated_mel_as) + | _ -> (acc, attr :: attrs_acc)) + ~init:(None, []) attrs let first_char_special (x : string) = match x with diff --git a/ppx/ast_attributes.mli b/ppx/ast_attributes.mli index afb5cf5f5..c0edfeef2 100644 --- a/ppx/ast_attributes.mli +++ b/ppx/ast_attributes.mli @@ -55,7 +55,7 @@ val iter_process_mel_string_int_unwrap_uncurry : attribute list -> [ `Nothing | `String | `Int | `Ignore | `Unwrap | `Uncurry of int option ] -val iter_process_mel_string_as : attribute list -> label option +val iter_process_mel_string_as : attribute list -> label option * attributes val iter_process_mel_int_as : attribute list -> int option val has_mel_optional : attribute list -> bool * attribute list val has_inline_payload : attribute list -> attribute option diff --git a/ppx/ast_derive/ast_derive_abstract.ml b/ppx/ast_derive/ast_derive_abstract.ml index 5eea1cb14..5237a33f4 100644 --- a/ppx/ast_derive/ast_derive_abstract.ml +++ b/ppx/ast_derive/ast_derive_abstract.ml @@ -103,15 +103,16 @@ let derive_js_constructor ?(is_deprecated = false) tdcl = } (maker, labels) -> - let newLabel = + let newLabel, remaining_attrs = match Ast_attributes.iter_process_mel_string_as pld_attributes with - | None -> pld_name - | Some new_name -> { pld_name with txt = new_name } + | None, remaining_attrs -> (pld_name, remaining_attrs) + | Some new_name, remaining_attrs -> + ({ pld_name with txt = new_name }, remaining_attrs) in let is_optional, remaining_attrs = - Ast_attributes.has_mel_optional pld_attributes + Ast_attributes.has_mel_optional remaining_attrs in let maker = if is_optional then @@ -220,17 +221,17 @@ let derive_getters_setters = } acc -> - let prim_as_name = + let prim_as_name, remaining_attrs = match Ast_attributes.iter_process_mel_string_as pld_attributes with - | None -> label_name - | Some new_name -> new_name + | None, remaining_attrs -> (label_name, remaining_attrs) + | Some new_name, remaining_attrs -> (new_name, remaining_attrs) in let prim = [ prim_as_name ] in let acc = let is_optional, _ = - Ast_attributes.has_mel_optional pld_attributes + Ast_attributes.has_mel_optional remaining_attrs in if is_optional then let optional_type = pld_type in diff --git a/ppx/ast_derive/ast_derive_js_mapper.ml b/ppx/ast_derive/ast_derive_js_mapper.ml index 3c69ff239..aaa5f4082 100644 --- a/ppx/ast_derive/ast_derive_js_mapper.ml +++ b/ppx/ast_derive/ast_derive_js_mapper.ml @@ -87,6 +87,7 @@ let buildMap (row_fields : row_field list) = let name : string = match Ast_attributes.iter_process_mel_string_as tag.prf_attributes + |> fst with | Some name -> has_mel_as := true; diff --git a/ppx/ast_external_mk.ml b/ppx/ast_external_mk.ml index db731407d..889d71ad4 100644 --- a/ppx/ast_external_mk.ml +++ b/ppx/ast_external_mk.ml @@ -185,6 +185,7 @@ let record_as_js_object ~loc | Lident obj_label -> let obj_label = Ast_attributes.iter_process_mel_string_as e.pexp_attributes + |> fst |> Option.value ~default:obj_label in ( { Asttypes.loc; txt = obj_label } :: labels, diff --git a/ppx/ast_external_process.ml b/ppx/ast_external_process.ml index 4b4ffeb5f..21e620900 100644 --- a/ppx/ast_external_process.ml +++ b/ppx/ast_external_process.ml @@ -490,6 +490,7 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) | _ -> Ast_attributes.iter_process_mel_string_as param_type.ty.ptyp_attributes + |> fst |> Option.map (fun name -> match param_type.label with | Labelled _ -> Labelled name diff --git a/ppx/ast_polyvar.ml b/ppx/ast_polyvar.ml index daa83fd91..fe054b4a5 100644 --- a/ppx/ast_polyvar.ml +++ b/ppx/ast_polyvar.ml @@ -104,6 +104,7 @@ let map_row_fields_into_strings ptyp_loc (row_fields : row_field list) : let name = match Ast_attributes.iter_process_mel_string_as tag.prf_attributes + |> fst with | Some name -> has_mel_as := true; @@ -115,6 +116,7 @@ let map_row_fields_into_strings ptyp_loc (row_fields : row_field list) : let name = match Ast_attributes.iter_process_mel_string_as tag.prf_attributes + |> fst with | Some name -> has_mel_as := true; From c5519337aeb2d670cc578eabc73b8dde4af76ffa Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Thu, 15 Aug 2024 22:51:17 -0700 Subject: [PATCH 3/7] add test --- test/blackbox-tests/deriving-separate.t | 2 +- .../mel-unwrap-in-jsproperties.t | 65 +++++++++++++++++++ 2 files changed, 66 insertions(+), 1 deletion(-) create mode 100644 test/blackbox-tests/mel-unwrap-in-jsproperties.t diff --git a/test/blackbox-tests/deriving-separate.t b/test/blackbox-tests/deriving-separate.t index e3725c106..6569d6a73 100644 --- a/test/blackbox-tests/deriving-separate.t +++ b/test/blackbox-tests/deriving-separate.t @@ -2,7 +2,7 @@ Tests for deriving `jsProperties, getSet` $ . ./setup.sh -`[@@deriving make_opt_keys]` just derives the constructor +`[@@deriving jsProperties]` just derives the constructor $ cat > x.ml < type chartDataItemType = diff --git a/test/blackbox-tests/mel-unwrap-in-jsproperties.t b/test/blackbox-tests/mel-unwrap-in-jsproperties.t new file mode 100644 index 000000000..bb48f9fa3 --- /dev/null +++ b/test/blackbox-tests/mel-unwrap-in-jsproperties.t @@ -0,0 +1,65 @@ +Tests for deriving `jsProperties, getSet` + + $ . ./setup.sh + +`[@@deriving jsProperties, getSet]` respects `[@mel.unwrap]` + + $ cat > x.ml < type t = { + > mutable action : [ \`String of string | \`Int of int ] option; + > [@mel.unwrap] [@mel.optional] + > other : [ \`String of int | \`Int of string ] option; [@mel.optional] + > } + > [@@deriving jsProperties, getSet] + > let () = + > let t = t ~action:(\`String "hello") () in + > (* Set action and expect the value to be unwrapped in the object too *) + > actionSet t (\`String "hello2"); + > Js.log2 "Action after setting: " t + > EOF + $ melc -ppx melppx -dsource x.ml + type t = + { + mutable action: [ `String of string | `Int of int ] option + [@mel.unwrap ][@mel.optional ]; + other: [ `String of int | `Int of string ] option [@mel.optional ]} + [@@deriving (jsProperties, getSet)] + include + struct + let _ = fun (_ : t) -> () + external t : + ?action:(([ `String of string | `Int of int ])[@mel.unwrap ]) -> + ?other:[ `String of int | `Int of string ] -> unit -> t = "" + "\132\149\166\190\000\000\000\029\000\000\000\011\000\000\000 \000\000\000\030\145\160\160C\161&action@\160\160A\161%other@\160\160@@@" + [@@ocaml.warning "-unboxable-type-in-prim-decl"][@@ocaml.warning + "-unboxable-type-in-prim-decl"] + external actionSet : + t -> [ `String of string | `Int of int ] -> unit = "action" + "\132\149\166\190\000\000\000\r\000\000\000\004\000\000\000\012\000\000\000\011\176\145BE\167&action@" + [@@ocaml.warning "-unboxable-type-in-prim-decl"][@@ocaml.warning + "-unboxable-type-in-prim-decl"] + external actionGet : + t -> [ `String of string | `Int of int ] option = "action" + "\132\149\166\190\000\000\000\r\000\000\000\004\000\000\000\012\000\000\000\011\176\145AB\168&action@" + [@@ocaml.warning "-unboxable-type-in-prim-decl"] + external otherGet : + t -> [ `String of int | `Int of string ] option = "other" + "\132\149\166\190\000\000\000\012\000\000\000\004\000\000\000\012\000\000\000\011\176\145AB\168%other@" + [@@ocaml.warning "-unboxable-type-in-prim-decl"] + end[@@ocaml.doc "@inline"][@@merlin.hide ] + let t = ((t ~action:(`String "hello") ()) + [@ocaml.warning "-ignored-extra-argument"][@ocaml.warning + "-ignored-extra-argument"]) + // Generated by Melange + 'use strict'; + + + const t = { + action: "hello" + }; + + exports.t = t; + /* No side effect */ + + + From 6efe8cf7f8d58a4788eb3f945577446a6bdcbb36 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Thu, 15 Aug 2024 22:51:37 -0700 Subject: [PATCH 4/7] show known issue --- .../mel-unwrap-in-jsproperties.t | 26 +++++++++++++------ 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/test/blackbox-tests/mel-unwrap-in-jsproperties.t b/test/blackbox-tests/mel-unwrap-in-jsproperties.t index bb48f9fa3..8c582cd07 100644 --- a/test/blackbox-tests/mel-unwrap-in-jsproperties.t +++ b/test/blackbox-tests/mel-unwrap-in-jsproperties.t @@ -47,19 +47,29 @@ Tests for deriving `jsProperties, getSet` "\132\149\166\190\000\000\000\012\000\000\000\004\000\000\000\012\000\000\000\011\176\145AB\168%other@" [@@ocaml.warning "-unboxable-type-in-prim-decl"] end[@@ocaml.doc "@inline"][@@merlin.hide ] - let t = ((t ~action:(`String "hello") ()) - [@ocaml.warning "-ignored-extra-argument"][@ocaml.warning - "-ignored-extra-argument"]) + let () = + let t = ((t ~action:(`String "hello") ()) + [@ocaml.warning "-ignored-extra-argument"]) in + ((actionSet t (`String "hello2")) + [@ocaml.warning "-ignored-extra-argument"]); + ((Js.log2 "Action after setting: " t) + [@ocaml.warning "-ignored-extra-argument"]) // Generated by Melange 'use strict'; - - + + const t = { action: "hello" }; - - exports.t = t; - /* No side effect */ + + t.action = { + NAME: "String", + VAL: "hello2" + }; + + console.log("Action after setting: ", t); + + /* Not a pure module */ From 117e4887e9834e153e69a881d20660fd22e70201 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Thu, 15 Aug 2024 22:59:52 -0700 Subject: [PATCH 5/7] fix: known issue --- ppx/ast_derive/ast_derive_abstract.ml | 15 +++++++++++---- test/blackbox-tests/mel-unwrap-in-jsproperties.t | 10 ++++------ 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/ppx/ast_derive/ast_derive_abstract.ml b/ppx/ast_derive/ast_derive_abstract.ml index 5237a33f4..e8850e783 100644 --- a/ppx/ast_derive/ast_derive_abstract.ml +++ b/ppx/ast_derive/ast_derive_abstract.ml @@ -229,10 +229,10 @@ let derive_getters_setters = | Some new_name, remaining_attrs -> (new_name, remaining_attrs) in let prim = [ prim_as_name ] in + let is_optional, remaining_attrs = + Ast_attributes.has_mel_optional remaining_attrs + in let acc = - let is_optional, _ = - Ast_attributes.has_mel_optional remaining_attrs - in if is_optional then let optional_type = pld_type in Val.mk ~loc:pld_loc @@ -258,7 +258,14 @@ let derive_getters_setters = in match pld_mutable with | Mutable -> - let pld_type = get_pld_type pld_type ~attrs:pld_attributes in + let pld_type = + let pld_type = get_pld_type pld_type ~attrs:pld_attributes in + { + pld_type with + ptyp_attributes = + List.append pld_type.ptyp_attributes remaining_attrs; + } + in let setter_type = [%type: [%t core_type] -> [%t pld_type] -> unit] in diff --git a/test/blackbox-tests/mel-unwrap-in-jsproperties.t b/test/blackbox-tests/mel-unwrap-in-jsproperties.t index 8c582cd07..898427dcb 100644 --- a/test/blackbox-tests/mel-unwrap-in-jsproperties.t +++ b/test/blackbox-tests/mel-unwrap-in-jsproperties.t @@ -34,8 +34,9 @@ Tests for deriving `jsProperties, getSet` [@@ocaml.warning "-unboxable-type-in-prim-decl"][@@ocaml.warning "-unboxable-type-in-prim-decl"] external actionSet : - t -> [ `String of string | `Int of int ] -> unit = "action" - "\132\149\166\190\000\000\000\r\000\000\000\004\000\000\000\012\000\000\000\011\176\145BE\167&action@" + t -> (([ `String of string | `Int of int ])[@mel.unwrap ]) -> unit = + "action" + "\132\149\166\190\000\000\000\021\000\000\000\b\000\000\000\024\000\000\000\023\176\144\160\160AA\160\160CA@E\167&action@" [@@ocaml.warning "-unboxable-type-in-prim-decl"][@@ocaml.warning "-unboxable-type-in-prim-decl"] external actionGet : @@ -62,10 +63,7 @@ Tests for deriving `jsProperties, getSet` action: "hello" }; - t.action = { - NAME: "String", - VAL: "hello2" - }; + t.action = "hello2"; console.log("Action after setting: ", t); From 873ca45e7038f50d71e8725f258b59f7a3b690a5 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Thu, 15 Aug 2024 23:10:46 -0700 Subject: [PATCH 6/7] add changelog entry --- Changes.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Changes.md b/Changes.md index 904dc0c6e..37c4ec2a2 100644 --- a/Changes.md +++ b/Changes.md @@ -9,6 +9,9 @@ Unreleased ([#1140](https://github.com/melange-re/melange/pull/1140)) - add Worker types to `melange.dom` ([#1147](https://github.com/melange-re/melange/pull/1147)) +- support `[@mel.unwrap]` and all other `external` FFI attributes in the maker + function for `[@@deriving jsProperties]` + ([#1162](https://github.com/melange-re/melange/pull/1162)) 4.0.1 2024-06-07 --------------- From ad63bc5349e84503dbdb298c81f017b4d5a43cd1 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Sun, 18 Aug 2024 19:50:08 -0700 Subject: [PATCH 7/7] demonstrate unsoundness with `getSet` --- .../mel-unwrap-in-jsproperties.t | 38 ++++++++++++++++--- 1 file changed, 33 insertions(+), 5 deletions(-) diff --git a/test/blackbox-tests/mel-unwrap-in-jsproperties.t b/test/blackbox-tests/mel-unwrap-in-jsproperties.t index 898427dcb..bb2e5462a 100644 --- a/test/blackbox-tests/mel-unwrap-in-jsproperties.t +++ b/test/blackbox-tests/mel-unwrap-in-jsproperties.t @@ -15,9 +15,18 @@ Tests for deriving `jsProperties, getSet` > let t = t ~action:(\`String "hello") () in > (* Set action and expect the value to be unwrapped in the object too *) > actionSet t (\`String "hello2"); - > Js.log2 "Action after setting: " t + > Js.log2 "Action after setting: " t; + > (* Expect the value to be what we declared in the type, but it isn't *) + > let action: [ \`String of string | \`Int of int ] option = actionGet t in + > (* This is, therefore, unsound *) + > match action with + > | None -> () + > | Some (\`String s) -> + > Js.log2 "action in t is string:" s; + > | Some (\`Int i) -> + > Js.log2 "action in t is int:" i; > EOF - $ melc -ppx melppx -dsource x.ml + $ melc -ppx melppx -dsource x.ml | tee x.js type t = { mutable action: [ `String of string | `Int of int ] option @@ -54,7 +63,15 @@ Tests for deriving `jsProperties, getSet` ((actionSet t (`String "hello2")) [@ocaml.warning "-ignored-extra-argument"]); ((Js.log2 "Action after setting: " t) - [@ocaml.warning "-ignored-extra-argument"]) + [@ocaml.warning "-ignored-extra-argument"]); + (let action : [ `String of string | `Int of int ] option = ((actionGet t) + [@ocaml.warning "-ignored-extra-argument"]) in + match action with + | None -> () + | Some (`String s) -> ((Js.log2 "action in t is string:" s) + [@ocaml.warning "-ignored-extra-argument"]) + | Some (`Int i) -> ((Js.log2 "action in t is int:" i) + [@ocaml.warning "-ignored-extra-argument"])) // Generated by Melange 'use strict'; @@ -67,7 +84,18 @@ Tests for deriving `jsProperties, getSet` console.log("Action after setting: ", t); + const action = t.action; + + if (action !== undefined) { + if (action.NAME === "Int") { + console.log("action in t is int:", action.VAL); + } else { + console.log("action in t is string:", action.VAL); + } + } + /* Not a pure module */ - - + $ node x.js + Action after setting: { action: 'hello2' } + action in t is string: undefined