Skip to content

Commit 4a89ca3

Browse files
bobzhangbobzhang
committed
ready for review
1 parent b9cd744 commit 4a89ca3

File tree

9 files changed

+999
-589
lines changed

9 files changed

+999
-589
lines changed

‎jscomp/all.depend

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -222,7 +222,8 @@ syntax/external_process.cmx : common/lam_methname.cmx \
222222
syntax/external_process.cmi
223223
syntax/ast_derive_abstract.cmx : syntax/external_process.cmx \
224224
ext/ext_list.cmx syntax/ast_literal.cmx syntax/ast_derive_util.cmx \
225-
syntax/ast_attributes.cmx syntax/ast_derive_abstract.cmi
225+
syntax/ast_core_type.cmx syntax/ast_attributes.cmx \
226+
syntax/ast_derive_abstract.cmi
226227
syntax/ast_derive_dyn.cmx : ext/ext_list.cmx syntax/bs_syntaxerr.cmx \
227228
syntax/ast_structure.cmx syntax/ast_derive_util.cmx syntax/ast_derive.cmx \
228229
syntax/ast_attributes.cmx syntax/ast_derive_dyn.cmi

‎jscomp/syntax/ast_derive_abstract.ml

Lines changed: 72 additions & 44 deletions
Original file line numberDiff line numberDiff line change
@@ -56,6 +56,10 @@ let rec checkNotFunciton (ty : Parsetree.core_type) =
5656
| Ptyp_extension _ -> ()
5757

5858

59+
let get_optional_attrs =
60+
[Ast_attributes.bs_get; Ast_attributes.bs_return_undefined]
61+
let get_attrs = [ Ast_attributes.bs_get ]
62+
let set_attrs = [Ast_attributes.bs_set]
5963
let handleTdcl (tdcl : Parsetree.type_declaration) =
6064
let core_type = U.core_type_of_type_declaration tdcl in
6165
let loc = tdcl.ptype_loc in
@@ -68,59 +72,83 @@ let handleTdcl (tdcl : Parsetree.type_declaration) =
6872
} in
6973
match tdcl.ptype_kind with
7074
| Ptype_record label_declarations ->
71-
let setter_accessor =
72-
Ext_list.fold_right (fun
73-
({pld_name = {txt = label_name; loc = label_loc} as pld_name;
75+
let is_private = tdcl.ptype_private = Private in
76+
let has_optional_field =
77+
List.exists (fun ({pld_type} : Parsetree.label_declaration) ->
78+
Ast_core_type.is_user_option pld_type
79+
) label_declarations in
80+
let setter_accessor, makeType, labels =
81+
Ext_list.fold_right
82+
(fun
83+
({pld_name =
84+
{txt = label_name; loc = label_loc} as pld_name;
7485
pld_type;
7586
pld_mutable;
76-
pld_attributes
77-
}:
78-
Parsetree.label_declaration) acc ->
87+
pld_attributes;
88+
pld_loc
89+
}:
90+
Parsetree.label_declaration) (acc, maker, labels) ->
7991
let () = checkNotFunciton pld_type in
80-
let prim =
92+
(* TODO: explain why *)
93+
let prim, newLabel =
8194
match Ast_attributes.iter_process_bs_string_as pld_attributes with
82-
| None -> [label_name]
83-
| Some new_name -> [new_name]
95+
| None ->
96+
[label_name], pld_name
97+
| Some new_name ->
98+
[new_name], {pld_name with txt = new_name}
8499
in
85-
let getter =
86-
Val.mk
87-
pld_name (* we always use this: it is fixed in ocaml API*)
88-
~attrs:[Ast_attributes.bs_get]
89-
~prim
90-
(Typ.arrow "" core_type pld_type) :: acc in
91-
match pld_mutable with
92-
| Mutable ->
93-
Val.mk
94-
{loc = label_loc; txt = label_name ^ "Set"}
95-
(* setter *)
96-
~attrs:[Ast_attributes.bs_set]
97-
~prim
98-
(Typ.arrow "" core_type (Typ.arrow "" pld_type (Ast_literal.type_unit ()))) :: getter
99-
| Immutable -> getter
100-
) label_declarations []
100+
let is_option = Ast_core_type.is_user_option pld_type in
101+
let getter_type =
102+
Typ.arrow ~loc "" core_type pld_type in
103+
let acc =
104+
Val.mk pld_name
105+
~attrs:(
106+
if is_option then get_optional_attrs
107+
else get_attrs)
108+
~prim getter_type :: acc in
109+
let is_current_field_mutable = pld_mutable = Mutable in
110+
let acc =
111+
if is_current_field_mutable then
112+
let setter_type =
113+
(Typ.arrow "" core_type
114+
(Typ.arrow ""
115+
(if is_option then
116+
Ast_core_type.extract_option_type_exn pld_type
117+
else pld_type)
118+
(Ast_literal.type_unit ()))) in
119+
Val.mk
120+
{loc = label_loc; txt = label_name ^ "Set"}
121+
(* setter *)
122+
~attrs:set_attrs
123+
~prim setter_type
124+
:: acc
125+
else acc in
126+
acc,
127+
(if is_option then
128+
Ast_core_type.opt_arrow pld_loc label_name pld_type maker
129+
else Typ.arrow ~loc:pld_loc label_name pld_type maker
130+
),
131+
(is_option, newLabel)::labels
132+
) label_declarations
133+
([],
134+
(if has_optional_field then
135+
Typ.arrow ~loc "" (Ast_literal.type_unit ()) core_type
136+
else core_type),
137+
[])
101138
in
102139
newTdcl,
103-
(match tdcl.ptype_private with
104-
| Private -> setter_accessor
105-
| Public ->
106-
let ty =
107-
Ext_list.fold_right (fun ({pld_name = {txt}; pld_type}: Parsetree.label_declaration) acc ->
108-
Typ.arrow txt pld_type acc
109-
) label_declarations core_type in
140+
(if is_private then
141+
setter_accessor
142+
else
110143
let myPrims =
111-
External_process.pval_prim_of_labels
112-
(List.map
113-
(fun ({pld_name; pld_attributes} : Parsetree.label_declaration) ->
114-
match Ast_attributes.iter_process_bs_string_as pld_attributes with
115-
| None -> pld_name
116-
| Some new_name -> {pld_name with txt = new_name}
117-
)
118-
label_declarations)
119-
in
144+
External_process.pval_prim_of_option_labels
145+
labels
146+
has_optional_field
147+
in
120148
let myMaker =
121-
Val.mk ~loc
122-
{loc; txt = type_name}
123-
~prim:myPrims ty in
149+
Val.mk ~loc
150+
{loc; txt = type_name}
151+
~prim:myPrims makeType in
124152
(myMaker :: setter_accessor))
125153

126154
| Ptype_abstract

‎jscomp/syntax/external_process.ml

Lines changed: 24 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -996,23 +996,29 @@ let pval_prim_of_labels (labels : string Asttypes.loc list)
996996
External_ffi_types.to_string (Ffi_obj_create arg_kinds) in
997997
[""; encoding]
998998

999-
let pval_prim_of_option_labels (labels : (bool * string Asttypes.loc) list)
999+
let pval_prim_of_option_labels
1000+
(labels : (bool * string Asttypes.loc) list)
1001+
(ends_with_unit : bool)
10001002
=
1001-
let arg_kinds =
1002-
Ext_list.fold_right
1003-
(fun (is_option,{Asttypes.loc ; txt }) arg_kinds
1004-
->
1005-
let label_name = (Lam_methname.translate ~loc txt) in
1006-
let arg_label =
1007-
if is_option then
1008-
External_arg_spec.optional label_name
1009-
else External_arg_spec.label label_name None
1010-
in
1011-
{External_arg_spec.arg_type = Nothing ;
1012-
arg_label } :: arg_kinds
1013-
)
1014-
labels [] in
1015-
let encoding =
1016-
External_ffi_types.to_string (Ffi_obj_create arg_kinds) in
1017-
[""; encoding]
1003+
let arg_kinds =
1004+
Ext_list.fold_right
1005+
(fun (is_option,{Asttypes.loc ; txt }) arg_kinds
1006+
->
1007+
let label_name = (Lam_methname.translate ~loc txt) in
1008+
let arg_label =
1009+
if is_option then
1010+
External_arg_spec.optional label_name
1011+
else External_arg_spec.label label_name None
1012+
in
1013+
{External_arg_spec.arg_type = Nothing ;
1014+
arg_label } :: arg_kinds
1015+
)
1016+
labels
1017+
(if ends_with_unit then
1018+
[External_arg_spec.empty_kind Extern_unit]
1019+
else [])
1020+
in
1021+
let encoding =
1022+
External_ffi_types.to_string (Ffi_obj_create arg_kinds) in
1023+
[""; encoding]
10181024

‎jscomp/syntax/external_process.mli

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -54,4 +54,6 @@ val pval_prim_of_labels : string Asttypes.loc list -> string list
5454

5555

5656
val pval_prim_of_option_labels :
57-
(bool * string Asttypes.loc) list -> string list
57+
(bool * string Asttypes.loc) list ->
58+
bool ->
59+
string list

‎jscomp/test/gpr_2614_test.js

Lines changed: 43 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,13 +1,14 @@
11
'use strict';
22

3+
var Js_primitive = require("../../lib/js/js_primitive.js");
34

45
var v = {
56
"Content-Type": 3,
67
l: 2,
78
open: 2
89
};
910

10-
var a = v["Content-Type"];
11+
v["Content-Type"];
1112

1213
var b = v.l;
1314

@@ -19,9 +20,48 @@ function ff() {
1920
return /* () */0;
2021
}
2122

23+
var partial_arg = /* Some */["x"];
24+
25+
function h0() {
26+
var tmp = {
27+
hi: 2
28+
};
29+
if (partial_arg) {
30+
tmp["lo-x"] = partial_arg[0];
31+
}
32+
return tmp;
33+
}
34+
35+
var h1 = {
36+
"lo-x": "x",
37+
hi: 2
38+
};
39+
40+
var h2 = {
41+
hi: 2
42+
};
43+
44+
function hh(x) {
45+
x["lo-x"] = "3";
46+
return Js_primitive.undefined_to_opt(x["lo-x"]);
47+
}
48+
49+
function hh2(x) {
50+
var match = x["lo-x"];
51+
if (match !== undefined) {
52+
return 1;
53+
} else {
54+
return 0;
55+
}
56+
}
57+
2258
exports.v = v;
23-
exports.a = a;
2459
exports.b = b;
2560
exports.c = c;
2661
exports.ff = ff;
27-
/* a Not a pure module */
62+
exports.h0 = h0;
63+
exports.h1 = h1;
64+
exports.h2 = h2;
65+
exports.hh = hh;
66+
exports.hh2 = hh2;
67+
/* Not a pure module */

‎jscomp/test/gpr_2614_test.ml

Lines changed: 36 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,3 +25,39 @@ let (a,b,c) = (v |. hi, v |. low, v |. x)
2525
let ff () =
2626
v |. hiSet 3;
2727
v |. lowSet 2
28+
29+
30+
type a = {
31+
mutable low : string option
32+
[@bs.as "lo-x"]
33+
;
34+
hi : int
35+
} [@@bs.deriving abstract]
36+
37+
38+
(**
39+
external a : ?low:int -> hi:int -> a
40+
low: a -> int option [@@bs.return undefined_to_opt]
41+
lowSet : a -> int -> unit
42+
*)
43+
let h0 =
44+
a ~hi:2 ~low:"x"
45+
46+
let h1 = a ~hi:2 ~low:"x" ()
47+
48+
let h2 = a ~hi:2 ()
49+
50+
let hh x =
51+
x |. lowSet "3";
52+
x |. low
53+
54+
(** should we make the type of
55+
56+
lowSet : a -> string option -> unit
57+
lowSet : a -> string -> unit
58+
*)
59+
60+
let hh2 x =
61+
match x |. low with
62+
| None -> 0
63+
| Some _ -> 1

0 commit comments

Comments
 (0)