Skip to content

Commit ba24756

Browse files
bobzhangbobzhang
committed
better error message and more tests
1 parent 61360f5 commit ba24756

9 files changed

+338
-162
lines changed

‎jscomp/bin/all_ounit_tests.i.ml

+91-61
Large diffs are not rendered by default.

‎jscomp/bin/all_ounit_tests.ml

+31-1
Original file line numberDiff line numberDiff line change
@@ -3922,7 +3922,37 @@ external ff :
39223922
(Ext_string.contain_substring should_err.stderr
39233923
"Ill defined"
39243924
)
3925-
end
3925+
end;
3926+
3927+
__LOC__ >:: begin fun _ ->
3928+
(** used in return value
3929+
This should fail, we did not
3930+
support uncurry return value yet
3931+
*)
3932+
let should_err = bsc_eval {|
3933+
external v3 :
3934+
int -> int -> (int -> int -> int [@bs.uncurry])
3935+
= ""[@@bs.val]
3936+
3937+
|} in
3938+
(* Ounit_cmd_util.debug_output should_err;*)
3939+
OUnit.assert_bool __LOC__
3940+
(Ext_string.contain_substring
3941+
should_err.stderr "bs.uncurry")
3942+
end ;
3943+
3944+
__LOC__ >:: begin fun _ ->
3945+
let should_err = bsc_eval {|
3946+
external v4 :
3947+
(int -> int -> int [@bs.uncurry]) = ""
3948+
[@@bs.val]
3949+
3950+
|} in
3951+
(* Ounit_cmd_util.debug_output should_err ; *)
3952+
OUnit.assert_bool __LOC__
3953+
(Ext_string.contain_substring
3954+
should_err.stderr "bs.uncurry")
3955+
end
39263956
]
39273957

39283958

‎jscomp/bin/bsdep.ml

+44-23
Original file line numberDiff line numberDiff line change
@@ -27885,7 +27885,7 @@ let rec get_uncurry_arity_aux (ty : t) acc =
2788527885

2788627886
(**
2788727887
{[ unit -> 'b ]} return arity 1
27888-
{[ 'a1 -> 'a2 -> ... 'aN -> 'b ]} return arity N
27888+
{[ 'a1 -> 'a2 -> ... 'aN -> 'b ]} return arity N
2788927889
*)
2789027890
let get_uncurry_arity (ty : t ) =
2789127891
match ty.ptyp_desc with
@@ -29128,24 +29128,24 @@ let get_arg_type ~nolabel optional
2912829128
| (`Uncurry opt_arity, ptyp_attributes), ptyp_desc ->
2912929129
let real_arity = Ast_core_type.get_uncurry_arity ptyp in
2913029130
(begin match opt_arity, real_arity with
29131-
| Some arity, `Not_function ->
29132-
Fn_uncurry_arity arity
29133-
| None, `Not_function ->
29134-
Location.raise_errorf
29135-
~loc:ptyp.ptyp_loc
29136-
"Can not infer the arity by syntax, either [@bs.uncurry n] or \n\
29137-
write it in arrow syntax
29131+
| Some arity, `Not_function ->
29132+
Fn_uncurry_arity arity
29133+
| None, `Not_function ->
29134+
Location.raise_errorf
29135+
~loc:ptyp.ptyp_loc
29136+
"Can not infer the arity by syntax, either [@bs.uncurry n] or \n\
29137+
write it in arrow syntax
2913829138
"
29139-
| None, `Arity arity ->
29140-
Fn_uncurry_arity arity
29141-
| Some arity, `Arity n ->
29142-
if n <> arity then
29143-
Location.raise_errorf
29144-
~loc:ptyp.ptyp_loc
29145-
"Inconsistent arity %d vs %d" arity n
29146-
else Fn_uncurry_arity arity
29147-
29148-
end, {ptyp with ptyp_attributes})
29139+
| None, `Arity arity ->
29140+
Fn_uncurry_arity arity
29141+
| Some arity, `Arity n ->
29142+
if n <> arity then
29143+
Location.raise_errorf
29144+
~loc:ptyp.ptyp_loc
29145+
"Inconsistent arity %d vs %d" arity n
29146+
else Fn_uncurry_arity arity
29147+
29148+
end, {ptyp with ptyp_attributes})
2914929149
| (`Nothing, ptyp_attributes), ptyp_desc ->
2915029150
begin match ptyp_desc with
2915129151
| Ptyp_constr ({txt = Lident "bool"}, [])
@@ -29293,8 +29293,14 @@ let process_external_attributes
2929329293
(init_st, []) prim_attributes
2929429294

2929529295

29296-
29297-
29296+
let rec has_bs_uncurry (attrs : Ast_attributes.t) =
29297+
match attrs with
29298+
| ({txt = "bs.uncurry"}, _) :: attrs ->
29299+
true
29300+
| _ :: attrs -> has_bs_uncurry attrs
29301+
| [] -> false
29302+
29303+
2929829304
(** Note that the passed [type_annotation] is already processed by visitor pattern before
2929929305
*)
2930029306
let handle_attributes
@@ -29303,13 +29309,28 @@ let handle_attributes
2930329309
(type_annotation : Parsetree.core_type)
2930429310
(prim_attributes : Ast_attributes.t) (prim_name : string)
2930529311
: Ast_core_type.t * string * Ast_ffi_types.t * Ast_attributes.t =
29312+
(** sanity check here
29313+
{[ int -> int -> (int -> int -> int [@bs.uncurry])]}
29314+
It does not make sense
29315+
*)
29316+
if has_bs_uncurry type_annotation.Parsetree.ptyp_attributes then
29317+
begin
29318+
Location.raise_errorf
29319+
~loc "[@@bs.uncurry] can not be applied to the whole defintion"
29320+
end;
29321+
2930629322
let prim_name_or_pval_prim =
2930729323
if String.length prim_name = 0 then `Nm_val pval_prim
2930829324
else `Nm_external prim_name (* need check name *)
2930929325
in
2931029326
let result_type, arg_types_ty =
2931129327
Ast_core_type.list_of_arrow type_annotation in
29312-
29328+
if has_bs_uncurry result_type.ptyp_attributes then
29329+
begin
29330+
Location.raise_errorf
29331+
~loc:result_type.ptyp_loc
29332+
"[@@bs.uncurry] can not be applied to tailed position"
29333+
end ;
2931329334
let (st, left_attrs) =
2931429335
process_external_attributes
2931529336
(arg_types_ty = [])
@@ -29379,7 +29400,7 @@ let handle_attributes
2937929400
(label,new_ty,attr,loc)::arg_types,
2938029401
((name, [], Ast_literal.type_string ~loc ()) :: result_types)
2938129402
| Fn_uncurry_arity _ ->
29382-
Location.raise_errorf ~loc
29403+
Location.raise_errorf ~loc
2938329404
"The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
2938429405
| Extern_unit -> assert false
2938529406
| NonNullString _
@@ -29414,7 +29435,7 @@ let handle_attributes
2941429435
| Arg_string_lit _ ->
2941529436
Location.raise_errorf ~loc "bs.as is not supported with optional yet"
2941629437
| Fn_uncurry_arity _ ->
29417-
Location.raise_errorf ~loc
29438+
Location.raise_errorf ~loc
2941829439
"The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
2941929440
| Extern_unit -> assert false
2942029441
| NonNullString _

‎jscomp/bin/bsppx.ml

+44-23
Original file line numberDiff line numberDiff line change
@@ -9900,7 +9900,7 @@ let rec get_uncurry_arity_aux (ty : t) acc =
99009900

99019901
(**
99029902
{[ unit -> 'b ]} return arity 1
9903-
{[ 'a1 -> 'a2 -> ... 'aN -> 'b ]} return arity N
9903+
{[ 'a1 -> 'a2 -> ... 'aN -> 'b ]} return arity N
99049904
*)
99059905
let get_uncurry_arity (ty : t ) =
99069906
match ty.ptyp_desc with
@@ -11206,24 +11206,24 @@ let get_arg_type ~nolabel optional
1120611206
| (`Uncurry opt_arity, ptyp_attributes), ptyp_desc ->
1120711207
let real_arity = Ast_core_type.get_uncurry_arity ptyp in
1120811208
(begin match opt_arity, real_arity with
11209-
| Some arity, `Not_function ->
11210-
Fn_uncurry_arity arity
11211-
| None, `Not_function ->
11212-
Location.raise_errorf
11213-
~loc:ptyp.ptyp_loc
11214-
"Can not infer the arity by syntax, either [@bs.uncurry n] or \n\
11215-
write it in arrow syntax
11209+
| Some arity, `Not_function ->
11210+
Fn_uncurry_arity arity
11211+
| None, `Not_function ->
11212+
Location.raise_errorf
11213+
~loc:ptyp.ptyp_loc
11214+
"Can not infer the arity by syntax, either [@bs.uncurry n] or \n\
11215+
write it in arrow syntax
1121611216
"
11217-
| None, `Arity arity ->
11218-
Fn_uncurry_arity arity
11219-
| Some arity, `Arity n ->
11220-
if n <> arity then
11221-
Location.raise_errorf
11222-
~loc:ptyp.ptyp_loc
11223-
"Inconsistent arity %d vs %d" arity n
11224-
else Fn_uncurry_arity arity
11225-
11226-
end, {ptyp with ptyp_attributes})
11217+
| None, `Arity arity ->
11218+
Fn_uncurry_arity arity
11219+
| Some arity, `Arity n ->
11220+
if n <> arity then
11221+
Location.raise_errorf
11222+
~loc:ptyp.ptyp_loc
11223+
"Inconsistent arity %d vs %d" arity n
11224+
else Fn_uncurry_arity arity
11225+
11226+
end, {ptyp with ptyp_attributes})
1122711227
| (`Nothing, ptyp_attributes), ptyp_desc ->
1122811228
begin match ptyp_desc with
1122911229
| Ptyp_constr ({txt = Lident "bool"}, [])
@@ -11371,8 +11371,14 @@ let process_external_attributes
1137111371
(init_st, []) prim_attributes
1137211372

1137311373

11374-
11375-
11374+
let rec has_bs_uncurry (attrs : Ast_attributes.t) =
11375+
match attrs with
11376+
| ({txt = "bs.uncurry"}, _) :: attrs ->
11377+
true
11378+
| _ :: attrs -> has_bs_uncurry attrs
11379+
| [] -> false
11380+
11381+
1137611382
(** Note that the passed [type_annotation] is already processed by visitor pattern before
1137711383
*)
1137811384
let handle_attributes
@@ -11381,13 +11387,28 @@ let handle_attributes
1138111387
(type_annotation : Parsetree.core_type)
1138211388
(prim_attributes : Ast_attributes.t) (prim_name : string)
1138311389
: Ast_core_type.t * string * Ast_ffi_types.t * Ast_attributes.t =
11390+
(** sanity check here
11391+
{[ int -> int -> (int -> int -> int [@bs.uncurry])]}
11392+
It does not make sense
11393+
*)
11394+
if has_bs_uncurry type_annotation.Parsetree.ptyp_attributes then
11395+
begin
11396+
Location.raise_errorf
11397+
~loc "[@@bs.uncurry] can not be applied to the whole defintion"
11398+
end;
11399+
1138411400
let prim_name_or_pval_prim =
1138511401
if String.length prim_name = 0 then `Nm_val pval_prim
1138611402
else `Nm_external prim_name (* need check name *)
1138711403
in
1138811404
let result_type, arg_types_ty =
1138911405
Ast_core_type.list_of_arrow type_annotation in
11390-
11406+
if has_bs_uncurry result_type.ptyp_attributes then
11407+
begin
11408+
Location.raise_errorf
11409+
~loc:result_type.ptyp_loc
11410+
"[@@bs.uncurry] can not be applied to tailed position"
11411+
end ;
1139111412
let (st, left_attrs) =
1139211413
process_external_attributes
1139311414
(arg_types_ty = [])
@@ -11457,7 +11478,7 @@ let handle_attributes
1145711478
(label,new_ty,attr,loc)::arg_types,
1145811479
((name, [], Ast_literal.type_string ~loc ()) :: result_types)
1145911480
| Fn_uncurry_arity _ ->
11460-
Location.raise_errorf ~loc
11481+
Location.raise_errorf ~loc
1146111482
"The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
1146211483
| Extern_unit -> assert false
1146311484
| NonNullString _
@@ -11492,7 +11513,7 @@ let handle_attributes
1149211513
| Arg_string_lit _ ->
1149311514
Location.raise_errorf ~loc "bs.as is not supported with optional yet"
1149411515
| Fn_uncurry_arity _ ->
11495-
Location.raise_errorf ~loc
11516+
Location.raise_errorf ~loc
1149611517
"The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
1149711518
| Extern_unit -> assert false
1149811519
| NonNullString _

‎jscomp/bin/whole_compiler.ml

+44-23
Original file line numberDiff line numberDiff line change
@@ -58093,7 +58093,7 @@ let rec get_uncurry_arity_aux (ty : t) acc =
5809358093

5809458094
(**
5809558095
{[ unit -> 'b ]} return arity 1
58096-
{[ 'a1 -> 'a2 -> ... 'aN -> 'b ]} return arity N
58096+
{[ 'a1 -> 'a2 -> ... 'aN -> 'b ]} return arity N
5809758097
*)
5809858098
let get_uncurry_arity (ty : t ) =
5809958099
match ty.ptyp_desc with
@@ -100504,24 +100504,24 @@ let get_arg_type ~nolabel optional
100504100504
| (`Uncurry opt_arity, ptyp_attributes), ptyp_desc ->
100505100505
let real_arity = Ast_core_type.get_uncurry_arity ptyp in
100506100506
(begin match opt_arity, real_arity with
100507-
| Some arity, `Not_function ->
100508-
Fn_uncurry_arity arity
100509-
| None, `Not_function ->
100510-
Location.raise_errorf
100511-
~loc:ptyp.ptyp_loc
100512-
"Can not infer the arity by syntax, either [@bs.uncurry n] or \n\
100513-
write it in arrow syntax
100507+
| Some arity, `Not_function ->
100508+
Fn_uncurry_arity arity
100509+
| None, `Not_function ->
100510+
Location.raise_errorf
100511+
~loc:ptyp.ptyp_loc
100512+
"Can not infer the arity by syntax, either [@bs.uncurry n] or \n\
100513+
write it in arrow syntax
100514100514
"
100515-
| None, `Arity arity ->
100516-
Fn_uncurry_arity arity
100517-
| Some arity, `Arity n ->
100518-
if n <> arity then
100519-
Location.raise_errorf
100520-
~loc:ptyp.ptyp_loc
100521-
"Inconsistent arity %d vs %d" arity n
100522-
else Fn_uncurry_arity arity
100523-
100524-
end, {ptyp with ptyp_attributes})
100515+
| None, `Arity arity ->
100516+
Fn_uncurry_arity arity
100517+
| Some arity, `Arity n ->
100518+
if n <> arity then
100519+
Location.raise_errorf
100520+
~loc:ptyp.ptyp_loc
100521+
"Inconsistent arity %d vs %d" arity n
100522+
else Fn_uncurry_arity arity
100523+
100524+
end, {ptyp with ptyp_attributes})
100525100525
| (`Nothing, ptyp_attributes), ptyp_desc ->
100526100526
begin match ptyp_desc with
100527100527
| Ptyp_constr ({txt = Lident "bool"}, [])
@@ -100669,8 +100669,14 @@ let process_external_attributes
100669100669
(init_st, []) prim_attributes
100670100670

100671100671

100672-
100673-
100672+
let rec has_bs_uncurry (attrs : Ast_attributes.t) =
100673+
match attrs with
100674+
| ({txt = "bs.uncurry"}, _) :: attrs ->
100675+
true
100676+
| _ :: attrs -> has_bs_uncurry attrs
100677+
| [] -> false
100678+
100679+
100674100680
(** Note that the passed [type_annotation] is already processed by visitor pattern before
100675100681
*)
100676100682
let handle_attributes
@@ -100679,13 +100685,28 @@ let handle_attributes
100679100685
(type_annotation : Parsetree.core_type)
100680100686
(prim_attributes : Ast_attributes.t) (prim_name : string)
100681100687
: Ast_core_type.t * string * Ast_ffi_types.t * Ast_attributes.t =
100688+
(** sanity check here
100689+
{[ int -> int -> (int -> int -> int [@bs.uncurry])]}
100690+
It does not make sense
100691+
*)
100692+
if has_bs_uncurry type_annotation.Parsetree.ptyp_attributes then
100693+
begin
100694+
Location.raise_errorf
100695+
~loc "[@@bs.uncurry] can not be applied to the whole defintion"
100696+
end;
100697+
100682100698
let prim_name_or_pval_prim =
100683100699
if String.length prim_name = 0 then `Nm_val pval_prim
100684100700
else `Nm_external prim_name (* need check name *)
100685100701
in
100686100702
let result_type, arg_types_ty =
100687100703
Ast_core_type.list_of_arrow type_annotation in
100688-
100704+
if has_bs_uncurry result_type.ptyp_attributes then
100705+
begin
100706+
Location.raise_errorf
100707+
~loc:result_type.ptyp_loc
100708+
"[@@bs.uncurry] can not be applied to tailed position"
100709+
end ;
100689100710
let (st, left_attrs) =
100690100711
process_external_attributes
100691100712
(arg_types_ty = [])
@@ -100755,7 +100776,7 @@ let handle_attributes
100755100776
(label,new_ty,attr,loc)::arg_types,
100756100777
((name, [], Ast_literal.type_string ~loc ()) :: result_types)
100757100778
| Fn_uncurry_arity _ ->
100758-
Location.raise_errorf ~loc
100779+
Location.raise_errorf ~loc
100759100780
"The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
100760100781
| Extern_unit -> assert false
100761100782
| NonNullString _
@@ -100790,7 +100811,7 @@ let handle_attributes
100790100811
| Arg_string_lit _ ->
100791100812
Location.raise_errorf ~loc "bs.as is not supported with optional yet"
100792100813
| Fn_uncurry_arity _ ->
100793-
Location.raise_errorf ~loc
100814+
Location.raise_errorf ~loc
100794100815
"The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
100795100816
| Extern_unit -> assert false
100796100817
| NonNullString _

0 commit comments

Comments
 (0)