Skip to content

Commit cba5604

Browse files
bobzhangbobzhang
committed
fix soundness issue introduced by bs.deriving abstract
1 parent 54e20fc commit cba5604

10 files changed

+206
-76
lines changed

‎jscomp/bin/all_ounit_tests.ml

+7
Original file line numberDiff line numberDiff line change
@@ -4135,6 +4135,13 @@ external ff :
41354135
OUnit.assert_bool __LOC__
41364136
(Ext_string.contain_substring should_err.stderr
41374137
"Unused")
4138+
end;
4139+
__LOC__ >:: begin fun _ ->
4140+
let should_err = bsc_check_eval {|
4141+
type -'a t = {k : 'a } [@@bs.deriving abstract]
4142+
|} in
4143+
OUnit.assert_bool __LOC__
4144+
(Ext_string.contain_substring should_err.stderr "contravariant")
41384145
end
41394146
(* __LOC__ >:: begin fun _ -> *)
41404147
(* let should_infer = perform_bsc [| "-i"; "-bs-eval"|] {| *)

‎jscomp/others/bs_Set.mli

+8-4
Original file line numberDiff line numberDiff line change
@@ -3,10 +3,14 @@
33

44
type ('elt, 'id) t0
55

6-
type ('elt, 'id) t = {
7-
dict : ('elt,'id) Bs_Cmp.t ;
8-
data : ('elt,'id) t0
9-
} [@@bs.deriving abstract]
6+
type ('elt, 'id) t
7+
8+
9+
external t :
10+
dict:('elt,'id) Bs_Cmp.t ->
11+
data : ('elt,'id) t0 -> ('elt, 'id) t = "" [@@bs.obj]
12+
external data : ('elt,'id) t -> ('elt,'id) t0 = "data" [@@bs.get]
13+
external dict : ('elt,'id) t -> ('elt,'id) Bs_Cmp.t = "dict" [@@bs.get]
1014
(** The type of sets. *)
1115

1216
val empty0: ('elt, 'id) t0

‎jscomp/ounit_tests/ounit_cmd_tests.ml

+14
Original file line numberDiff line numberDiff line change
@@ -235,6 +235,20 @@ external ff :
235235
OUnit.assert_bool __LOC__
236236
(Ext_string.contain_substring should_err.stderr
237237
"Unused")
238+
end;
239+
__LOC__ >:: begin fun _ ->
240+
let should_err = bsc_check_eval {|
241+
type -'a t = {k : 'a } [@@bs.deriving abstract]
242+
|} in
243+
OUnit.assert_bool __LOC__
244+
(Ext_string.contain_substring should_err.stderr "contravariant")
245+
end;
246+
__LOC__ >:: begin fun _ ->
247+
let should_err = bsc_check_eval {|
248+
type 'a t = {k : int -> 'a } [@@bs.deriving abstract]
249+
|} in
250+
OUnit.assert_bool __LOC__
251+
(Ext_string.contain_substring should_err.stderr "not allowed")
238252
end
239253
(* __LOC__ >:: begin fun _ -> *)
240254
(* let should_infer = perform_bsc [| "-i"; "-bs-eval"|] {| *)

‎jscomp/syntax/ast_derive_abstract.ml

+27-15
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,26 @@ let handle_config (config : Parsetree.expression option) =
3434
U.invalid_config config
3535
| None -> ()
3636

37+
(* see #2337
38+
TODO: relax it to allow (int -> int [@bs])
39+
*)
40+
let rec checkNotFunciton (ty : Parsetree.core_type) =
41+
match ty.ptyp_desc with
42+
| Ptyp_poly (_,ty) -> checkNotFunciton ty
43+
| Ptyp_alias (ty,_) -> checkNotFunciton ty
44+
| Ptyp_arrow _ ->
45+
Location.raise_errorf
46+
~loc:ty.ptyp_loc
47+
"syntactic function type is not allowed when working with abstract bs.deriving, create a named type as work around"
48+
| Ptyp_any
49+
| Ptyp_var _
50+
| Ptyp_tuple _
51+
| Ptyp_constr _
52+
| Ptyp_object _
53+
| Ptyp_class _
54+
| Ptyp_variant _
55+
| Ptyp_package _
56+
| Ptyp_extension _ -> ()
3757
let handleTdcl (tdcl : Parsetree.type_declaration) =
3858
let core_type = U.core_type_of_type_declaration tdcl in
3959
let loc = tdcl.ptype_loc in
@@ -60,19 +80,21 @@ let handleTdcl (tdcl : Parsetree.type_declaration) =
6080
Ext_list.fold_right (fun (x: Parsetree.label_declaration) acc ->
6181
let pld_name = x.pld_name.txt in
6282
let pld_loc = x.pld_name.loc in
83+
let pld_type = x.pld_type in
84+
let () = checkNotFunciton pld_type in
6385
let setter =
6486
Val.mk
6587
{loc = pld_loc; txt = pld_name}
6688
~attrs:[Ast_attributes.bs_get]
6789
~prim:[pld_name]
68-
(Typ.arrow "" core_type x.pld_type) :: acc in
90+
(Typ.arrow "" core_type pld_type) :: acc in
6991
match x.pld_mutable with
7092
| Mutable ->
7193
Val.mk
7294
{loc = pld_loc; txt = pld_name ^ "Set"}
7395
~attrs:[Ast_attributes.bs_set]
7496
~prim:[pld_name]
75-
(Typ.arrow "" core_type (Typ.arrow "" x.pld_type (Ast_literal.type_unit ()))) :: setter
97+
(Typ.arrow "" core_type (Typ.arrow "" pld_type (Ast_literal.type_unit ()))) :: setter
7698
| Immutable -> setter
7799
) label_declarations []
78100
in
@@ -83,7 +105,7 @@ let handleTdcl (tdcl : Parsetree.type_declaration) =
83105
| Ptype_variant _
84106
| Ptype_open ->
85107
U.notApplicable tdcl.ptype_loc derivingName;
86-
newTdcl, []
108+
tdcl, []
87109

88110
let handleTdcls tdcls =
89111
let tdcls, code =
@@ -94,16 +116,6 @@ let handleTdcls tdcls =
94116
Ext_list.map_append (fun x -> Str.primitive x) value_descriptions sts
95117

96118
) tdcls ([],[]) in
97-
Str.type_ tdcls, code
119+
Str.type_ tdcls :: code
120+
(* still need perform transformation for non-abstract type*)
98121

99-
100-
let handleTdclsInSig (tdcls : Parsetree.type_declaration list) =
101-
let tdcls, code =
102-
List.fold_right (fun tdcl (tdcls, sts) ->
103-
match handleTdcl tdcl with
104-
ntdcl, value_descriptions ->
105-
ntdcl::tdcls,
106-
Ext_list.map_append (fun x -> Sig.value x) value_descriptions sts
107-
108-
) tdcls ([],[]) in
109-
Sig.type_ tdcls, code

‎jscomp/syntax/ppx_entry.ml

+15-13
Original file line numberDiff line numberDiff line change
@@ -724,11 +724,7 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
724724
->
725725
let loc = sigi.psig_loc in
726726
if Ast_payload.isAbstract actions then
727-
let type_, codes = Ast_derive_abstract.handleTdclsInSig tdcls in
728-
Ast_signature.fuseAll ~loc
729-
(type_ ::
730-
self.signature self
731-
codes)
727+
Location.raise_errorf ~loc "bs.deriving abstract is not supported in signature language"
732728
else
733729
let newTdcls = newTdcls tdcls newAttrs in
734730
Ast_signature.fuseAll ~loc
@@ -800,24 +796,30 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
800796
explict_nonrec
801797
}, newAttrs ->
802798
let loc = str.pstr_loc in
799+
let tdcls2 = newTdcls tdcls newAttrs in
800+
let newStr =
801+
self.structure_item self
802+
{str with pstr_desc = Pstr_type tdcls2} in
803803
if Ast_payload.isAbstract actions then
804-
let type_, codes = Ast_derive_abstract.handleTdcls tdcls in
804+
let codes = Ast_derive_abstract.handleTdcls tdcls in
805805
Ast_structure.fuseAll ~loc
806-
(type_::
807-
self.structure self
808-
codes)
806+
(
807+
Ast_structure.constraint_ ~loc
808+
[newStr] []::
809+
self.structure self
810+
codes)
809811
else
810-
let tdcls2 = newTdcls tdcls newAttrs in
811812
Ast_structure.fuseAll ~loc
812-
(self.structure self
813+
(newStr ::
814+
self.structure self
813815
(
814-
{str with pstr_desc = Pstr_type tdcls2} ::
815816
List.map
816817
(fun action ->
817818
Ast_derive.gen_structure_signature
818819
loc
819820
tdcls action explict_nonrec
820-
) actions))
821+
) actions
822+
))
821823
| {bs_deriving = None }, _ ->
822824
Bs_ast_mapper.default_mapper.structure_item self str
823825
end

‎jscomp/test/bs_abstract_test.js

+8
Original file line numberDiff line numberDiff line change
@@ -8,5 +8,13 @@ var v = {
88

99
v.tl = v;
1010

11+
var f = {
12+
k: (function (x, y) {
13+
return +(x === y);
14+
}),
15+
y: "x"
16+
};
17+
1118
exports.v = v;
19+
exports.f = f;
1220
/* v Not a pure module */

‎jscomp/test/bs_abstract_test.ml

+10-1
Original file line numberDiff line numberDiff line change
@@ -11,4 +11,13 @@ type 'a linked_list =
1111

1212
let v = linked_list ~hd:3 ~tl:Js.null
1313

14-
;; tlSet v (Js.Null.return v)
14+
;; tlSet v (Js.Null.return v)
15+
16+
type t = int -> int -> bool [@bs]
17+
and x = {
18+
k : t;
19+
y : string
20+
} [@@bs.deriving abstract]
21+
22+
23+
let f = x ~k:(fun[@bs] x y -> x = y) ~y:"x"

‎lib/bsdep.ml

+39-14
Original file line numberDiff line numberDiff line change
@@ -29143,6 +29143,26 @@ let handle_config (config : Parsetree.expression option) =
2914329143
U.invalid_config config
2914429144
| None -> ()
2914529145

29146+
(* see #2337
29147+
TODO: relax it to allow (int -> int [@bs])
29148+
*)
29149+
let rec checkNotFunciton (ty : Parsetree.core_type) =
29150+
match ty.ptyp_desc with
29151+
| Ptyp_poly (_,ty) -> checkNotFunciton ty
29152+
| Ptyp_alias (ty,_) -> checkNotFunciton ty
29153+
| Ptyp_arrow _ ->
29154+
Location.raise_errorf
29155+
~loc:ty.ptyp_loc
29156+
"syntactic function type is not allowed when working with abstract bs.deriving, create a named type as work around"
29157+
| Ptyp_any
29158+
| Ptyp_var _
29159+
| Ptyp_tuple _
29160+
| Ptyp_constr _
29161+
| Ptyp_object _
29162+
| Ptyp_class _
29163+
| Ptyp_variant _
29164+
| Ptyp_package _
29165+
| Ptyp_extension _ -> ()
2914629166
let handleTdcl (tdcl : Parsetree.type_declaration) =
2914729167
let core_type = U.core_type_of_type_declaration tdcl in
2914829168
let loc = tdcl.ptype_loc in
@@ -29169,19 +29189,21 @@ let handleTdcl (tdcl : Parsetree.type_declaration) =
2916929189
Ext_list.fold_right (fun (x: Parsetree.label_declaration) acc ->
2917029190
let pld_name = x.pld_name.txt in
2917129191
let pld_loc = x.pld_name.loc in
29192+
let pld_type = x.pld_type in
29193+
let () = checkNotFunciton pld_type in
2917229194
let setter =
2917329195
Val.mk
2917429196
{loc = pld_loc; txt = pld_name}
2917529197
~attrs:[Ast_attributes.bs_get]
2917629198
~prim:[pld_name]
29177-
(Typ.arrow "" core_type x.pld_type) :: acc in
29199+
(Typ.arrow "" core_type pld_type) :: acc in
2917829200
match x.pld_mutable with
2917929201
| Mutable ->
2918029202
Val.mk
2918129203
{loc = pld_loc; txt = pld_name ^ "Set"}
2918229204
~attrs:[Ast_attributes.bs_set]
2918329205
~prim:[pld_name]
29184-
(Typ.arrow "" core_type (Typ.arrow "" x.pld_type (Ast_literal.type_unit ()))) :: setter
29206+
(Typ.arrow "" core_type (Typ.arrow "" pld_type (Ast_literal.type_unit ()))) :: setter
2918529207
| Immutable -> setter
2918629208
) label_declarations []
2918729209
in
@@ -37302,11 +37324,7 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
3730237324
->
3730337325
let loc = sigi.psig_loc in
3730437326
if Ast_payload.isAbstract actions then
37305-
let type_, codes = Ast_derive_abstract.handleTdclsInSig tdcls in
37306-
Ast_signature.fuseAll ~loc
37307-
(type_ ::
37308-
self.signature self
37309-
codes)
37327+
Location.raise_errorf ~loc "bs.deriving abstract is not supported in signature language"
3731037328
else
3731137329
let newTdcls = newTdcls tdcls newAttrs in
3731237330
Ast_signature.fuseAll ~loc
@@ -37378,24 +37396,31 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
3737837396
explict_nonrec
3737937397
}, newAttrs ->
3738037398
let loc = str.pstr_loc in
37399+
let tdcls2 = newTdcls tdcls newAttrs in
37400+
let newStr =
37401+
self.structure_item self
37402+
{str with pstr_desc = Pstr_type tdcls2} in
3738137403
if Ast_payload.isAbstract actions then
3738237404
let type_, codes = Ast_derive_abstract.handleTdcls tdcls in
3738337405
Ast_structure.fuseAll ~loc
37384-
(type_::
37385-
self.structure self
37386-
codes)
37406+
(
37407+
Ast_structure.constraint_ ~loc
37408+
[newStr] []::
37409+
type_::
37410+
self.structure self
37411+
codes)
3738737412
else
37388-
let tdcls2 = newTdcls tdcls newAttrs in
3738937413
Ast_structure.fuseAll ~loc
37390-
(self.structure self
37414+
(newStr ::
37415+
self.structure self
3739137416
(
37392-
{str with pstr_desc = Pstr_type tdcls2} ::
3739337417
List.map
3739437418
(fun action ->
3739537419
Ast_derive.gen_structure_signature
3739637420
loc
3739737421
tdcls action explict_nonrec
37398-
) actions))
37422+
) actions
37423+
))
3739937424
| {bs_deriving = None }, _ ->
3740037425
Bs_ast_mapper.default_mapper.structure_item self str
3740137426
end

0 commit comments

Comments
 (0)