Skip to content

Commit 8af3728

Browse files
bobzhangbobzhang
committed
snapshot
1 parent 45517e3 commit 8af3728

File tree

4 files changed

+236
-144
lines changed

4 files changed

+236
-144
lines changed

‎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

‎lib/4.06.1/unstable/js_refmt_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)