Skip to content

Commit

Permalink
Support field aliases for obj ppx
Browse files Browse the repository at this point in the history
  • Loading branch information
@DZakh
DZakh committed Sep 22, 2023
1 parent a8c7f15 commit e556137
Show file tree
Hide file tree
Showing 3 changed files with 55 additions and 19 deletions.
53 changes: 34 additions & 19 deletions jscomp/frontend/ast_external_process.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -349,6 +349,13 @@ type response = {
no_inline_cross_module: bool;
}

let get_maybe_obj_field_alias (attributes) =
attributes |> List.find_map (fun (attr: Parsetree.attribute) -> match attr with
| ({txt = "as"; _}, PStr [ { pstr_desc = Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string (alias, _)); _}, _); _ } ]) -> Some(alias)
| _ -> None
)


let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
(arg_types_ty : Ast_core_type.param_type list)
(result_type : Ast_core_type.t) : Parsetree.core_type * External_ffi_types.t
Expand Down Expand Up @@ -398,7 +405,11 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
| _ ->
Location.raise_errorf ~loc
"expect label, optional, or unit here")
| Labelled name -> (
| Labelled label -> (
let fieldName = match get_maybe_obj_field_alias param_type.attr with
| Some(alias) -> alias
| None -> label
in
let obj_arg_type = refine_obj_arg_type ~nolabel:false ty in
match obj_arg_type with
| Ignore ->
Expand All @@ -407,39 +418,39 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
result_types )
| Arg_cst _ ->
( {
obj_arg_label = External_arg_spec.obj_label name;
obj_arg_label = External_arg_spec.obj_label fieldName;
obj_arg_type;
},
arg_types,
(* ignored in [arg_types], reserved in [result_types] *)
result_types )
| Nothing ->
( {
obj_arg_label = External_arg_spec.obj_label name;
obj_arg_label = External_arg_spec.obj_label fieldName;
obj_arg_type;
},
param_type :: arg_types,
Parsetree.Otag ({Asttypes.txt = name; loc}, [], ty)
Parsetree.Otag ({Asttypes.txt = fieldName; loc}, [], ty)
:: result_types )
| Int _ ->
( {
obj_arg_label = External_arg_spec.obj_label name;
obj_arg_label = External_arg_spec.obj_label fieldName;
obj_arg_type;
},
param_type :: arg_types,
Otag
( {Asttypes.txt = name; loc},
( {Asttypes.txt = fieldName; loc},
[],
Ast_literal.type_int ~loc () )
:: result_types )
| Poly_var_string _ ->
( {
obj_arg_label = External_arg_spec.obj_label name;
obj_arg_label = External_arg_spec.obj_label fieldName;
obj_arg_type;
},
param_type :: arg_types,
Otag
( {Asttypes.txt = name; loc},
( {Asttypes.txt = fieldName; loc},
[],
Ast_literal.type_string ~loc () )
:: result_types )
Expand All @@ -449,11 +460,15 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
| Extern_unit -> assert false
| Poly_var _ ->
Location.raise_errorf ~loc
"%@obj label %s does not support such arg type" name
"%@obj label %s does not support such arg type" label
| Unwrap ->
Location.raise_errorf ~loc
"%@obj label %s does not support %@unwrap arguments" name)
| Optional name -> (
"%@obj label %s does not support %@unwrap arguments" label)
| Optional label -> (
let fieldName = match get_maybe_obj_field_alias param_type.attr with
| Some(alias) -> alias
| None -> label
in
let obj_arg_type = get_opt_arg_type ~nolabel:false ty in
match obj_arg_type with
| Ignore ->
Expand All @@ -469,35 +484,35 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
in
( {
obj_arg_label =
External_arg_spec.optional for_sure_not_nested name;
External_arg_spec.optional for_sure_not_nested fieldName;
obj_arg_type;
},
param_type :: arg_types,
Parsetree.Otag
( {Asttypes.txt = name; loc},
( {Asttypes.txt = fieldName; loc},
[],
Ast_comb.to_undefined_type loc ty )
:: result_types )
| Int _ ->
( {
obj_arg_label = External_arg_spec.optional true name;
obj_arg_label = External_arg_spec.optional true fieldName;
obj_arg_type;
},
param_type :: arg_types,
Otag
( {Asttypes.txt = name; loc},
( {Asttypes.txt = fieldName; loc},
[],
Ast_comb.to_undefined_type loc
@@ Ast_literal.type_int ~loc () )
:: result_types )
| Poly_var_string _ ->
( {
obj_arg_label = External_arg_spec.optional true name;
obj_arg_label = External_arg_spec.optional true fieldName;
obj_arg_type;
},
param_type :: arg_types,
Otag
( {Asttypes.txt = name; loc},
( {Asttypes.txt = fieldName; loc},
[],
Ast_comb.to_undefined_type loc
@@ Ast_literal.type_string ~loc () )
Expand All @@ -511,10 +526,10 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
| Extern_unit -> assert false
| Poly_var _ ->
Location.raise_errorf ~loc
"%@obj label %s does not support such arg type" name
"%@obj label %s does not support such arg type" label
| Unwrap ->
Location.raise_errorf ~loc
"%@obj label %s does not support %@unwrap arguments" name)
"%@obj label %s does not support %@unwrap arguments" label)
in
(new_arg_label :: arg_labels, new_arg_types, output_tys))
in
Expand Down
12 changes: 12 additions & 0 deletions jscomp/test/external_ppx.js
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

9 changes: 9 additions & 0 deletions jscomp/test/external_ppx.res
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,6 +9,15 @@ external make_config: (~length: 'a, ~width: int) => unit = ""

@obj external opt_make: (~length: int, ~width: int=?) => (_ as 'event) = ""

@obj
external renamed_make: (
@as("type") ~_type: string,
@as("WIDTH") ~width: int=?,
~normal: float,
) => (_ as 'event) = ""

let renamed = renamed_make(~_type="123", ~normal=12.)

@obj
external ff: (
~hi: int,
Expand Down

0 comments on commit e556137

Please sign in to comment.