Skip to content

Commit 01dd83a

Browse files
author
Hongbo Zhang
committed
clean
1 parent 8420635 commit 01dd83a

File tree

1 file changed

+123
-85
lines changed

1 file changed

+123
-85
lines changed

‎jscomp/syntax/ppx_entry.ml

Lines changed: 123 additions & 85 deletions
Original file line numberDiff line numberDiff line change
@@ -69,87 +69,120 @@ let reset () =
6969

7070

7171

72+
let process_getter_setter ~no ~get ~set
73+
loc name
74+
(attrs : Ast_attributes.t)
75+
(ty : Parsetree.core_type) acc =
76+
match Ast_attributes.process_method_attributes_rev attrs with
77+
| {get = None; set = None}, _ -> no ty :: acc
78+
| st , pctf_attributes
79+
->
80+
let get_acc =
81+
match st.set with
82+
| Some `No_get -> acc
83+
| None
84+
| Some `Get ->
85+
let lift txt =
86+
Typ.constr ~loc {txt ; loc} [ty] in
87+
let (null,undefined) =
88+
match st with
89+
| {get = Some (null, undefined) } -> (null, undefined)
90+
| {get = None} -> (false, false ) in
91+
let ty =
92+
match (null,undefined) with
93+
| false, false -> ty
94+
| true, false -> lift Ast_literal.Lid.js_null
95+
| false, true -> lift Ast_literal.Lid.js_undefined
96+
| true , true -> lift Ast_literal.Lid.js_null_undefined in
97+
get ty name pctf_attributes
98+
:: acc
99+
in
100+
if st.set = None then get_acc
101+
else
102+
set ty (name ^ Literals.setter_suffix) pctf_attributes
103+
:: get_acc
104+
105+
106+
107+
let handle_class_type_field self ({pctf_loc = loc } as ctf : Parsetree.class_type_field) acc =
108+
match ctf.pctf_desc with
109+
| Pctf_method
110+
(name, private_flag, virtual_flag, ty)
111+
->
112+
begin match Ast_attributes.process_method_attributes_rev ctf.pctf_attributes with
113+
| {get = None; set = None}, _ ->
114+
let ty =
115+
match ty.ptyp_desc with
116+
| Ptyp_arrow (label, args, body)
117+
->
118+
Ast_util.to_method_type
119+
ty.ptyp_loc self label args body
120+
121+
| Ptyp_poly (strs, {ptyp_desc = Ptyp_arrow (label, args, body);
122+
ptyp_loc})
123+
->
124+
{ty with ptyp_desc =
125+
Ptyp_poly(strs,
126+
Ast_util.to_method_type
127+
ptyp_loc self label args body )}
128+
| _ ->
129+
self.typ self ty
130+
in
131+
{ctf with
132+
pctf_desc =
133+
Pctf_method (name , private_flag, virtual_flag, ty)}
134+
:: acc
135+
136+
| st , pctf_attributes
137+
->
138+
let get_acc =
139+
match st.set with
140+
| Some `No_get -> acc
141+
| None
142+
| Some `Get ->
143+
let lift txt =
144+
Typ.constr ~loc {txt ; loc} [ty] in
145+
let (null,undefined) =
146+
match st with
147+
| {get = Some (null, undefined) } -> (null, undefined)
148+
| {get = None} -> (false, false ) in
149+
let ty =
150+
match (null,undefined) with
151+
| false, false -> ty
152+
| true, false -> lift Ast_literal.Lid.js_null
153+
| false, true -> lift Ast_literal.Lid.js_undefined
154+
| true , true -> lift Ast_literal.Lid.js_null_undefined in
155+
{ctf with
156+
pctf_desc =
157+
Pctf_method (name ,
158+
private_flag,
159+
virtual_flag,
160+
self.typ self ty
161+
);
162+
pctf_attributes}
163+
:: acc
164+
in
165+
if st.set = None then get_acc
166+
else
167+
{ctf with
168+
pctf_desc =
169+
Pctf_method (name ^ Literals.setter_suffix,
170+
private_flag,
171+
virtual_flag,
172+
Ast_util.to_method_type
173+
loc self "" ty
174+
(Ast_literal.type_unit ~loc ())
175+
);
176+
pctf_attributes}
177+
:: get_acc
178+
end
179+
| Pctf_inherit _
180+
| Pctf_val _
181+
| Pctf_constraint _
182+
| Pctf_attribute _
183+
| Pctf_extension _ ->
184+
Ast_mapper.default_mapper.class_type_field self ctf :: acc
72185

73-
let handle_class_type_field acc =
74-
(fun self ({pctf_loc = loc } as ctf : Parsetree.class_type_field) ->
75-
match ctf.Parsetree.pctf_desc with
76-
| Pctf_method
77-
(name, private_flag, virtual_flag, ty)
78-
->
79-
begin match Ast_attributes.process_method_attributes_rev ctf.pctf_attributes with
80-
| {get = None; set = None}, _ ->
81-
let ty =
82-
match ty.ptyp_desc with
83-
| Ptyp_arrow (label, args, body)
84-
->
85-
Ast_util.to_method_type
86-
ty.ptyp_loc self label args body
87-
88-
| Ptyp_poly (strs, {ptyp_desc = Ptyp_arrow (label, args, body);
89-
ptyp_loc})
90-
->
91-
{ty with ptyp_desc =
92-
Ptyp_poly(strs,
93-
Ast_util.to_method_type
94-
ptyp_loc self label args body )}
95-
| _ ->
96-
self.typ self ty
97-
in
98-
{ctf with
99-
pctf_desc =
100-
Pctf_method (name , private_flag, virtual_flag, ty)}
101-
:: acc
102-
103-
| st , pctf_attributes
104-
->
105-
let get_acc =
106-
match st.set with
107-
| Some `No_get -> acc
108-
| None
109-
| Some `Get ->
110-
let lift txt =
111-
Typ.constr ~loc {txt ; loc} [ty] in
112-
let (null,undefined) =
113-
match st with
114-
| {get = Some (null, undefined) } -> (null, undefined)
115-
| {get = None} -> (false, false ) in
116-
let ty =
117-
match (null,undefined) with
118-
| false, false -> ty
119-
| true, false -> lift Ast_literal.Lid.js_null
120-
| false, true -> lift Ast_literal.Lid.js_undefined
121-
| true , true -> lift Ast_literal.Lid.js_null_undefined in
122-
{ctf with
123-
pctf_desc =
124-
Pctf_method (name ,
125-
private_flag,
126-
virtual_flag,
127-
self.typ self ty
128-
);
129-
pctf_attributes}
130-
:: acc
131-
in
132-
if st.set = None then get_acc
133-
else
134-
{ctf with
135-
pctf_desc =
136-
Pctf_method (name ^ Literals.setter_suffix,
137-
private_flag,
138-
virtual_flag,
139-
Ast_util.to_method_type
140-
loc self "" ty
141-
(Ast_literal.type_unit ~loc ())
142-
);
143-
pctf_attributes}
144-
:: get_acc
145-
end
146-
| Pctf_inherit _
147-
| Pctf_val _
148-
| Pctf_constraint _
149-
| Pctf_attribute _
150-
| Pctf_extension _ ->
151-
Ast_mapper.default_mapper.class_type_field self ctf :: acc
152-
)
153186
(*
154187
Attributes are very hard to attribute
155188
(since ptyp_attributes could happen in so many places),
@@ -194,7 +227,7 @@ let handle_typ
194227
match Ast_attributes.process_attributes_rev ptyp_attrs with
195228
| `Nothing, _ ->
196229
label, ptyp_attrs , check_auto_uncurry core_type
197-
| `Uncurry, _ ->
230+
| `Uncurry, ptyp_attrs ->
198231
label , ptyp_attrs,
199232
check_auto_uncurry
200233
{ core_type with
@@ -411,7 +444,14 @@ let rec unsafe_mapper : Ast_mapper.mapper =
411444
| Some e ->
412445
Location.raise_errorf
413446
~loc:e.pexp_loc "`with` construct is not supported in bs.obj ")
414-
else (* could be supported using `Object.assign`? *)
447+
else
448+
(* could be supported using `Object.assign`?
449+
type
450+
{[
451+
external update : 'a Js.t -> 'b Js.t -> 'a Js.t = ""
452+
constraint 'b :> 'a
453+
]}
454+
*)
415455
Ast_mapper.default_mapper.expr self e
416456
| Pexp_object {pcstr_self; pcstr_fields} ->
417457
begin match Ast_attributes.process_bs e.pexp_attributes with
@@ -443,9 +483,7 @@ let rec unsafe_mapper : Ast_mapper.mapper =
443483
{ctd with
444484
pcty_desc = Pcty_signature {
445485
pcsig_self ;
446-
pcsig_fields = List.fold_right (fun f acc ->
447-
handle_class_type_field acc self f
448-
) pcsig_fields []
486+
pcsig_fields = List.fold_right (handle_class_type_field self) pcsig_fields []
449487
};
450488
pcty_attributes
451489
}

0 commit comments

Comments
 (0)