Skip to content

Commit 2f3a44e

Browse files
bobzhangbobzhang
authored
Merge pull request #4581 from BuckleScript/ffi_cleanup_3
ffi cleanup, prepare to support bs.as undefined
2 parents 123f7d3 + 8af3728 commit 2f3a44e

File tree

8 files changed

+302
-180
lines changed

8 files changed

+302
-180
lines changed

‎jscomp/syntax/ast_core_type.ml

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -42,8 +42,6 @@ let lift_option_type ({ptyp_loc} as ty:t) : t =
4242
ptyp_attributes = []
4343
}
4444

45-
let is_any (ty : t) =
46-
ty.ptyp_desc = Ptyp_any
4745

4846
open Ast_helper
4947

‎jscomp/syntax/ast_core_type.mli

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,7 @@ type t = Parsetree.core_type
2828

2929

3030
val lift_option_type : t -> t
31-
val is_any : t -> bool
31+
3232
(* val replace_result : t -> t -> t *)
3333

3434
(* val opt_arrow: Location.t -> string -> t -> t -> t *)

‎jscomp/syntax/ast_external_process.ml

Lines changed: 58 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -96,8 +96,33 @@ let spec_of_ptyp
9696
(* is_optional = false
9797
*)
9898
let refine_arg_type ~(nolabel:bool) (ptyp : Ast_core_type.t)
99+
: External_arg_spec.attr =
100+
(if ptyp.ptyp_desc = Ptyp_any then
101+
let ptyp_attrs = ptyp.ptyp_attributes in
102+
let result = Ast_attributes.iter_process_bs_string_or_int_as ptyp_attrs in
103+
(* when ppx start dropping attributes
104+
we should warn, there is a trade off whether
105+
we should warn dropped non bs attribute or not
106+
*)
107+
Bs_ast_invariant.warn_discarded_unused_attributes ptyp_attrs;
108+
match result with
109+
| None ->
110+
Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
111+
| Some (Int i) -> (* (_[@bs.as ])*)
112+
(* This type is used in bs.obj only to construct obj type*)
113+
Arg_cst(External_arg_spec.cst_int i)
114+
| Some (Str i)->
115+
Arg_cst (External_arg_spec.cst_string i)
116+
| Some (Json_str s) ->
117+
(* FIXME: This seems to be wrong in bs.obj, we should disable such payload in bs.obj *)
118+
Arg_cst (External_arg_spec.cst_json ptyp.ptyp_loc s)
119+
else (* ([`a|`b] [@bs.string]) *)
120+
spec_of_ptyp nolabel ptyp
121+
)
122+
123+
let refine_obj_arg_type ~(nolabel:bool) (ptyp : Ast_core_type.t)
99124
: Ast_core_type.t * External_arg_spec.attr =
100-
if Ast_core_type.is_any ptyp then (* (_[@bs.as ])*)
125+
if ptyp.ptyp_desc = Ptyp_any then
101126
let ptyp_attrs = ptyp.ptyp_attributes in
102127
let result = Ast_attributes.iter_process_bs_string_or_int_as ptyp_attrs in
103128
(* when ppx start dropping attributes
@@ -108,18 +133,16 @@ let refine_arg_type ~(nolabel:bool) (ptyp : Ast_core_type.t)
108133
match result with
109134
| None ->
110135
Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
111-
| Some (Int i) ->
136+
| Some (Int i) -> (* (_[@bs.as ])*)
112137
(* This type is used in bs.obj only to construct obj type*)
113138
Ast_literal.type_int ~loc:ptyp.ptyp_loc (), Arg_cst(External_arg_spec.cst_int i)
114139
| Some (Str i)->
115140
Ast_literal.type_string ~loc:ptyp.ptyp_loc (), Arg_cst (External_arg_spec.cst_string i)
116-
| Some (Json_str s) ->
117-
(* FIXME: This seems to be wrong in bs.obj, we should disable such payload in bs.obj *)
118-
Ast_literal.type_string ~loc:ptyp.ptyp_loc (), Arg_cst (External_arg_spec.cst_json ptyp.ptyp_loc s)
141+
| Some (Json_str _) ->
142+
Location.raise_errorf ~loc:ptyp.ptyp_loc "json payload is not supported in bs.obj since its type can not be inferred"
119143
else (* ([`a|`b] [@bs.string]) *)
120-
ptyp, spec_of_ptyp nolabel ptyp
144+
ptyp, spec_of_ptyp nolabel ptyp
121145

122-
123146
(** Given the type of argument, process its [bs.] attribute and new type,
124147
The new type is currently used to reconstruct the external type
125148
and result type in [@@bs.obj]
@@ -133,7 +156,7 @@ let get_opt_arg_type
133156
~(nolabel : bool)
134157
(ptyp : Ast_core_type.t) :
135158
External_arg_spec.attr =
136-
if Ast_core_type.is_any ptyp then (* (_[@bs.as ])*)
159+
if ptyp.ptyp_desc = Ptyp_any then (* (_[@bs.as ])*)
137160
(* extenral f : ?x:_ -> y:int -> _ = "" [@@bs.obj] is not allowed *)
138161
Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external;
139162
(* ([`a|`b] [@bs.string]) *)
@@ -409,14 +432,15 @@ let process_obj
409432
let new_arg_label, new_arg_types, output_tys =
410433
match arg_label with
411434
| Nolabel ->
412-
let new_ty, arg_type = refine_arg_type ~nolabel:true ty in
413-
if arg_type = Extern_unit then
414-
External_arg_spec.empty_kind arg_type,
415-
{param_type with ty = new_ty}::arg_types, result_types
416-
else
417-
Location.raise_errorf ~loc "expect label, optional, or unit here"
435+
begin match ty.ptyp_desc with
436+
| Ptyp_constr({txt = Lident "unit";_}, []) ->
437+
External_arg_spec.empty_kind Extern_unit,
438+
param_type ::arg_types, result_types
439+
| _ ->
440+
Location.raise_errorf ~loc "expect label, optional, or unit here"
441+
end
418442
| Labelled name ->
419-
let new_ty, obj_arg_type = refine_arg_type ~nolabel:false ty in
443+
let new_ty, obj_arg_type = refine_obj_arg_type ~nolabel:false ty in
420444
begin match obj_arg_type with
421445
| Ignore ->
422446
External_arg_spec.empty_kind obj_arg_type,
@@ -496,10 +520,11 @@ let process_obj
496520
output_tys) in
497521

498522
let result =
499-
if Ast_core_type.is_any result_type then
523+
if result_type.ptyp_desc = Ptyp_any then
500524
Ast_core_type.make_obj ~loc result_types
501525
else
502-
fst (refine_arg_type ~nolabel:true result_type)
526+
result_type
527+
(* TODO: do we need do some error checking here *)
503528
(* result type can not be labeled *)
504529
in
505530
Ast_compatible.mk_fn_type new_arg_types_ty result,
@@ -858,15 +883,15 @@ let handle_attributes
858883
let init : External_arg_spec.params * Ast_compatible.param_type list * int =
859884
match external_desc.val_send_pipe with
860885
| Some obj ->
861-
let new_ty, arg_type = refine_arg_type ~nolabel:true obj in
886+
let arg_type = refine_arg_type ~nolabel:true obj in
862887
begin match arg_type with
863888
| Arg_cst _ ->
864889
Location.raise_errorf ~loc:obj.ptyp_loc "[@bs.as] is not supported in bs.send type "
865890
| _ ->
866891
(* more error checking *)
867892
[{arg_label = Arg_empty; arg_type}],
868893
[{label = Nolabel;
869-
ty = new_ty;
894+
ty = obj;
870895
attr = [];
871896
loc = obj.ptyp_loc} ],
872897
0
@@ -882,7 +907,7 @@ let handle_attributes
882907
Location.raise_errorf ~loc "[@@@@bs.splice] expect the last type to be a non optional"
883908
| Labelled _ | Nolabel
884909
->
885-
if Ast_core_type.is_any ty then
910+
if ty.ptyp_desc = Ptyp_any then
886911
Location.raise_errorf ~loc "[@@@@bs.splice] expect the last type to be an array";
887912
if spec_of_ptyp true ty <> Nothing then
888913
Location.raise_errorf ~loc "[@@@@bs.splice] expect the last type to be an array";
@@ -905,20 +930,20 @@ let handle_attributes
905930
Arg_optional, arg_type,
906931
param_type :: arg_types end
907932
| Labelled _ ->
908-
begin match refine_arg_type ~nolabel:false ty with
909-
| _, (Arg_cst _ as arg_type) ->
910-
Arg_label , arg_type, arg_types
911-
| new_ty, arg_type ->
912-
Arg_label , arg_type,
913-
{param_type with ty = new_ty} :: arg_types
914-
end
933+
let arg_type = refine_arg_type ~nolabel:false ty in
934+
Arg_label , arg_type,
935+
(match arg_type with
936+
| Arg_cst _ ->
937+
arg_types
938+
| _ ->
939+
param_type :: arg_types)
915940
| Nolabel ->
916-
begin match refine_arg_type ~nolabel:true ty with
917-
| _ , (Arg_cst _ as arg_type) ->
918-
Arg_empty , arg_type, arg_types
919-
| new_ty , arg_type ->
920-
Arg_empty, arg_type, {param_type with ty = new_ty} :: arg_types
921-
end
941+
let arg_type = refine_arg_type ~nolabel:true ty in
942+
Arg_empty , arg_type, (match arg_type with
943+
| Arg_cst _ ->
944+
arg_types
945+
| _ ->
946+
param_type :: arg_types)
922947
in
923948
({ arg_label ;
924949
arg_type

‎jscomp/test/gpr_1170.ml

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,13 @@ external set_hi :
88
"hi"
99
[@@bs.set]
1010

11+
12+
#if 0 then
13+
external ff_json : hi:int -> lo:(_[@bs.as {json|null|json}]) -> _ = "" [@@bs.obj]
14+
15+
let uu : < hi : int; lo : string > Js.t = ff_json ~hi:3
16+
#end
17+
1118
let f resp =
1219
set_okay resp ;
1320
set_hi resp

‎lib/4.06.1/unstable/js_compiler.ml

Lines changed: 59 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -402101,7 +402101,7 @@ type t = Parsetree.core_type
402101402101

402102402102

402103402103
val lift_option_type : t -> t
402104-
val is_any : t -> bool
402104+
402105402105
(* val replace_result : t -> t -> t *)
402106402106

402107402107
(* val opt_arrow: Location.t -> string -> t -> t -> t *)
@@ -402193,8 +402193,6 @@ let lift_option_type ({ptyp_loc} as ty:t) : t =
402193402193
ptyp_attributes = []
402194402194
}
402195402195

402196-
let is_any (ty : t) =
402197-
ty.ptyp_desc = Ptyp_any
402198402196

402199402197
open Ast_helper
402200402198

@@ -406852,8 +406850,33 @@ let spec_of_ptyp
406852406850
(* is_optional = false
406853406851
*)
406854406852
let refine_arg_type ~(nolabel:bool) (ptyp : Ast_core_type.t)
406853+
: External_arg_spec.attr =
406854+
(if ptyp.ptyp_desc = Ptyp_any then
406855+
let ptyp_attrs = ptyp.ptyp_attributes in
406856+
let result = Ast_attributes.iter_process_bs_string_or_int_as ptyp_attrs in
406857+
(* when ppx start dropping attributes
406858+
we should warn, there is a trade off whether
406859+
we should warn dropped non bs attribute or not
406860+
*)
406861+
Bs_ast_invariant.warn_discarded_unused_attributes ptyp_attrs;
406862+
match result with
406863+
| None ->
406864+
Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
406865+
| Some (Int i) -> (* (_[@bs.as ])*)
406866+
(* This type is used in bs.obj only to construct obj type*)
406867+
Arg_cst(External_arg_spec.cst_int i)
406868+
| Some (Str i)->
406869+
Arg_cst (External_arg_spec.cst_string i)
406870+
| Some (Json_str s) ->
406871+
(* FIXME: This seems to be wrong in bs.obj, we should disable such payload in bs.obj *)
406872+
Arg_cst (External_arg_spec.cst_json ptyp.ptyp_loc s)
406873+
else (* ([`a|`b] [@bs.string]) *)
406874+
spec_of_ptyp nolabel ptyp
406875+
)
406876+
406877+
let refine_obj_arg_type ~(nolabel:bool) (ptyp : Ast_core_type.t)
406855406878
: Ast_core_type.t * External_arg_spec.attr =
406856-
if Ast_core_type.is_any ptyp then (* (_[@bs.as ])*)
406879+
if ptyp.ptyp_desc = Ptyp_any then
406857406880
let ptyp_attrs = ptyp.ptyp_attributes in
406858406881
let result = Ast_attributes.iter_process_bs_string_or_int_as ptyp_attrs in
406859406882
(* when ppx start dropping attributes
@@ -406864,18 +406887,16 @@ let refine_arg_type ~(nolabel:bool) (ptyp : Ast_core_type.t)
406864406887
match result with
406865406888
| None ->
406866406889
Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
406867-
| Some (Int i) ->
406890+
| Some (Int i) -> (* (_[@bs.as ])*)
406868406891
(* This type is used in bs.obj only to construct obj type*)
406869406892
Ast_literal.type_int ~loc:ptyp.ptyp_loc (), Arg_cst(External_arg_spec.cst_int i)
406870406893
| Some (Str i)->
406871406894
Ast_literal.type_string ~loc:ptyp.ptyp_loc (), Arg_cst (External_arg_spec.cst_string i)
406872-
| Some (Json_str s) ->
406873-
(* FIXME: This seems to be wrong in bs.obj, we should disable such payload in bs.obj *)
406874-
Ast_literal.type_string ~loc:ptyp.ptyp_loc (), Arg_cst (External_arg_spec.cst_json ptyp.ptyp_loc s)
406895+
| Some (Json_str _) ->
406896+
Location.raise_errorf ~loc:ptyp.ptyp_loc "json payload is not supported in bs.obj since its type can not be inferred"
406875406897
else (* ([`a|`b] [@bs.string]) *)
406876-
ptyp, spec_of_ptyp nolabel ptyp
406898+
ptyp, spec_of_ptyp nolabel ptyp
406877406899

406878-
406879406900
(** Given the type of argument, process its [bs.] attribute and new type,
406880406901
The new type is currently used to reconstruct the external type
406881406902
and result type in [@@bs.obj]
@@ -406889,7 +406910,7 @@ let get_opt_arg_type
406889406910
~(nolabel : bool)
406890406911
(ptyp : Ast_core_type.t) :
406891406912
External_arg_spec.attr =
406892-
if Ast_core_type.is_any ptyp then (* (_[@bs.as ])*)
406913+
if ptyp.ptyp_desc = Ptyp_any then (* (_[@bs.as ])*)
406893406914
(* extenral f : ?x:_ -> y:int -> _ = "" [@@bs.obj] is not allowed *)
406894406915
Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external;
406895406916
(* ([`a|`b] [@bs.string]) *)
@@ -407165,14 +407186,15 @@ let process_obj
407165407186
let new_arg_label, new_arg_types, output_tys =
407166407187
match arg_label with
407167407188
| Nolabel ->
407168-
let new_ty, arg_type = refine_arg_type ~nolabel:true ty in
407169-
if arg_type = Extern_unit then
407170-
External_arg_spec.empty_kind arg_type,
407171-
{param_type with ty = new_ty}::arg_types, result_types
407172-
else
407173-
Location.raise_errorf ~loc "expect label, optional, or unit here"
407189+
begin match ty.ptyp_desc with
407190+
| Ptyp_constr({txt = Lident "unit";_}, []) ->
407191+
External_arg_spec.empty_kind Extern_unit,
407192+
param_type ::arg_types, result_types
407193+
| _ ->
407194+
Location.raise_errorf ~loc "expect label, optional, or unit here"
407195+
end
407174407196
| Labelled name ->
407175-
let new_ty, obj_arg_type = refine_arg_type ~nolabel:false ty in
407197+
let new_ty, obj_arg_type = refine_obj_arg_type ~nolabel:false ty in
407176407198
begin match obj_arg_type with
407177407199
| Ignore ->
407178407200
External_arg_spec.empty_kind obj_arg_type,
@@ -407252,10 +407274,11 @@ let process_obj
407252407274
output_tys) in
407253407275

407254407276
let result =
407255-
if Ast_core_type.is_any result_type then
407277+
if result_type.ptyp_desc = Ptyp_any then
407256407278
Ast_core_type.make_obj ~loc result_types
407257407279
else
407258-
fst (refine_arg_type ~nolabel:true result_type)
407280+
result_type
407281+
(* TODO: do we need do some error checking here *)
407259407282
(* result type can not be labeled *)
407260407283
in
407261407284
Ast_compatible.mk_fn_type new_arg_types_ty result,
@@ -407614,15 +407637,15 @@ let handle_attributes
407614407637
let init : External_arg_spec.params * Ast_compatible.param_type list * int =
407615407638
match external_desc.val_send_pipe with
407616407639
| Some obj ->
407617-
let new_ty, arg_type = refine_arg_type ~nolabel:true obj in
407640+
let arg_type = refine_arg_type ~nolabel:true obj in
407618407641
begin match arg_type with
407619407642
| Arg_cst _ ->
407620407643
Location.raise_errorf ~loc:obj.ptyp_loc "[@bs.as] is not supported in bs.send type "
407621407644
| _ ->
407622407645
(* more error checking *)
407623407646
[{arg_label = Arg_empty; arg_type}],
407624407647
[{label = Nolabel;
407625-
ty = new_ty;
407648+
ty = obj;
407626407649
attr = [];
407627407650
loc = obj.ptyp_loc} ],
407628407651
0
@@ -407638,7 +407661,7 @@ let handle_attributes
407638407661
Location.raise_errorf ~loc "[@@@@bs.splice] expect the last type to be a non optional"
407639407662
| Labelled _ | Nolabel
407640407663
->
407641-
if Ast_core_type.is_any ty then
407664+
if ty.ptyp_desc = Ptyp_any then
407642407665
Location.raise_errorf ~loc "[@@@@bs.splice] expect the last type to be an array";
407643407666
if spec_of_ptyp true ty <> Nothing then
407644407667
Location.raise_errorf ~loc "[@@@@bs.splice] expect the last type to be an array";
@@ -407661,20 +407684,20 @@ let handle_attributes
407661407684
Arg_optional, arg_type,
407662407685
param_type :: arg_types end
407663407686
| Labelled _ ->
407664-
begin match refine_arg_type ~nolabel:false ty with
407665-
| _, (Arg_cst _ as arg_type) ->
407666-
Arg_label , arg_type, arg_types
407667-
| new_ty, arg_type ->
407668-
Arg_label , arg_type,
407669-
{param_type with ty = new_ty} :: arg_types
407670-
end
407687+
let arg_type = refine_arg_type ~nolabel:false ty in
407688+
Arg_label , arg_type,
407689+
(match arg_type with
407690+
| Arg_cst _ ->
407691+
arg_types
407692+
| _ ->
407693+
param_type :: arg_types)
407671407694
| Nolabel ->
407672-
begin match refine_arg_type ~nolabel:true ty with
407673-
| _ , (Arg_cst _ as arg_type) ->
407674-
Arg_empty , arg_type, arg_types
407675-
| new_ty , arg_type ->
407676-
Arg_empty, arg_type, {param_type with ty = new_ty} :: arg_types
407677-
end
407695+
let arg_type = refine_arg_type ~nolabel:true ty in
407696+
Arg_empty , arg_type, (match arg_type with
407697+
| Arg_cst _ ->
407698+
arg_types
407699+
| _ ->
407700+
param_type :: arg_types)
407678407701
in
407679407702
({ arg_label ;
407680407703
arg_type

0 commit comments

Comments
 (0)