support [@mel.unwrap] in @@deriving jsProperties

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
 ---------------

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
@@ -407,16 +409,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 }; _ } ->

ppx/ast_attributes.mli

@@ -55,9 +55,9 @@ 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
+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
 

ppx/ast_derive/ast_derive_abstract.ml

@@ -46,23 +46,49 @@ 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 -> (
       let loc = tdcl.ptype_loc in
       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 =
@@ -77,19 +103,35 @@ 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 remaining_attrs
             in
-            let is_optional = 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 +146,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 *)
@@ -145,16 +221,19 @@ 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 is_optional, remaining_attrs =
+              Ast_attributes.has_mel_optional remaining_attrs
+            in
             let acc =
-              if Ast_attributes.has_mel_optional pld_attributes then
+              if is_optional then
                 let optional_type = pld_type in
                 Val.mk ~loc:pld_loc
                   (if light then pld_name
@@ -179,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

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;

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 =
         {

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 =
@@ -209,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,

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 ->

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
@@ -1012,10 +1013,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 +1161,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 +1179,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;