1+ (* Copyright (C) 2018 Authors of BuckleScript
2+ *
3+ * This program is free software: you can redistribute it and/or modify
4+ * it under the terms of the GNU Lesser General Public License as published by
5+ * the Free Software Foundation, either version 3 of the License, or
6+ * (at your option) any later version.
7+ *
8+ * In addition to the permissions granted to you by the LGPL, you may combine
9+ * or link a "work that uses the Library" with a publicly distributed version
10+ * of this file to produce a combined library or application, then distribute
11+ * that combined work under the terms of your choosing, with no requirement
12+ * to comply with the obligations normally placed on you by section 4 of the
13+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
14+ * should you choose to use a later version).
15+ *
16+ * This program is distributed in the hope that it will be useful,
17+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
18+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19+ * GNU Lesser General Public License for more details.
20+ *
21+ * You should have received a copy of the GNU Lesser General Public License
22+ * along with this program; if not, write to the Free Software
23+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
24+ open Ast_helper
25+ let process_getter_setter ~no ~get ~set
26+ loc name
27+ (attrs : Ast_attributes.t )
28+ (ty : Parsetree.core_type ) acc =
29+ match Ast_attributes. process_method_attributes_rev attrs with
30+ | {get = None ; set = None } , _ -> no ty :: acc
31+ | st , pctf_attributes
32+ ->
33+ let get_acc =
34+ match st.set with
35+ | Some `No_get -> acc
36+ | None
37+ | Some `Get ->
38+ let lift txt =
39+ Typ. constr ~loc {txt ; loc} [ty] in
40+ let (null,undefined) =
41+ match st with
42+ | {get = Some (null , undefined ) } -> (null, undefined)
43+ | {get = None } -> (false , false ) in
44+ let ty =
45+ match (null,undefined) with
46+ | false , false -> ty
47+ | true , false -> lift Ast_literal.Lid. js_null
48+ | false , true -> lift Ast_literal.Lid. js_undefined
49+ | true , true -> lift Ast_literal.Lid. js_null_undefined in
50+ get ty name pctf_attributes
51+ :: acc
52+ in
53+ if st.set = None then get_acc
54+ else
55+ set ty (name ^ Literals. setter_suffix) pctf_attributes
56+ :: get_acc
57+
58+
59+ let handle_class_type_field self
60+ ({pctf_loc = loc } as ctf : Parsetree.class_type_field )
61+ acc =
62+ match ctf.pctf_desc with
63+ | Pctf_method
64+ (name, private_flag, virtual_flag, ty)
65+ ->
66+ let no (ty : Parsetree.core_type ) =
67+ let ty =
68+ match ty.ptyp_desc with
69+ | Ptyp_arrow (label, args, body)
70+ ->
71+ Ast_util. to_method_type
72+ ty.ptyp_loc self label args body
73+
74+ | Ptyp_poly (strs, {ptyp_desc = Ptyp_arrow (label, args, body);
75+ ptyp_loc})
76+ ->
77+ {ty with ptyp_desc =
78+ Ptyp_poly (strs,
79+ Ast_util. to_method_type
80+ ptyp_loc self label args body )}
81+ | _ ->
82+ self.typ self ty
83+ in
84+ {ctf with
85+ pctf_desc =
86+ Pctf_method (name , private_flag, virtual_flag, ty)}
87+ in
88+ let get ty name pctf_attributes =
89+ {ctf with
90+ pctf_desc =
91+ Pctf_method (name ,
92+ private_flag,
93+ virtual_flag,
94+ self.typ self ty
95+ );
96+ pctf_attributes} in
97+ let set ty name pctf_attributes =
98+ {ctf with
99+ pctf_desc =
100+ Pctf_method (name,
101+ private_flag,
102+ virtual_flag,
103+ Ast_util. to_method_type
104+ loc self " "
105+ (Ast_literal. type_unit ~loc () )
106+ );
107+ pctf_attributes} in
108+ process_getter_setter ~no ~get ~set loc name ctf.pctf_attributes ty acc
109+
110+ | Pctf_inherit _
111+ | Pctf_val _
112+ | Pctf_constraint _
113+ | Pctf_attribute _
114+ | Pctf_extension _ ->
115+ Bs_ast_mapper. default_mapper.class_type_field self ctf :: acc
116+
117+
118+ (*
119+ Attributes are very hard to attribute
120+ (since ptyp_attributes could happen in so many places),
121+ and write ppx extensions correctly,
122+ we can only use it locally
123+ *)
124+
125+ let handle_core_type
126+ ~(super : Bs_ast_mapper.mapper )
127+ ~(self : Bs_ast_mapper.mapper )
128+ (ty : Parsetree.core_type )
129+ record_as_js_object
130+ =
131+ match ty with
132+ | {ptyp_desc = Ptyp_extension ({txt = (" bs.obj" | " obj" PTyp ty)}
133+ ->
134+ Ext_ref. non_exn_protect record_as_js_object true
135+ (fun _ -> self.typ self ty )
136+ | {ptyp_attributes ;
137+ ptyp_desc = Ptyp_arrow (label, args, body);
138+ (* let it go without regard label names,
139+ it will report error later when the label is not empty
140+ *)
141+ ptyp_loc = loc
142+ } ->
143+ begin match Ast_attributes. process_attributes_rev ptyp_attributes with
144+ | `Uncurry , ptyp_attributes ->
145+ Ast_util. to_uncurry_type loc self label args body
146+ | `Meth_callback , ptyp_attributes ->
147+ Ast_util. to_method_callback_type loc self label args body
148+ | `Method , ptyp_attributes ->
149+ Ast_util. to_method_type loc self label args body
150+ | `Nothing , _ ->
151+ Bs_ast_mapper. default_mapper.typ self ty
152+ end
153+ | {
154+ ptyp_desc = Ptyp_object ( methods, closed_flag) ;
155+ ptyp_loc = loc
156+ } ->
157+ let (+>) attr (typ : Parsetree.core_type ) =
158+ {typ with ptyp_attributes = attr :: typ .ptyp_attributes} in
159+ let new_methods =
160+ Ext_list. fold_right (fun (label , ptyp_attrs , core_type ) acc ->
161+ let get ty name attrs =
162+ let attrs, core_type =
163+ match Ast_attributes. process_attributes_rev attrs with
164+ | `Nothing , attrs -> attrs, ty (* #1678 *)
165+ | `Uncurry , attrs ->
166+ attrs, Ast_attributes. bs +> ty
167+ | `Method , _
168+ -> Location. raise_errorf ~loc " bs.get/set conflicts with bs.meth"
169+ | `Meth_callback , attrs ->
170+ attrs, Ast_attributes. bs_this +> ty
171+ in
172+ name , attrs, self.typ self core_type in
173+ let set ty name attrs =
174+ let attrs, core_type =
175+ match Ast_attributes. process_attributes_rev attrs with
176+ | `Nothing , attrs -> attrs, ty
177+ | `Uncurry , attrs ->
178+ attrs, Ast_attributes. bs +> ty
179+ | `Method , _
180+ -> Location. raise_errorf ~loc " bs.get/set conflicts with bs.meth"
181+ | `Meth_callback , attrs ->
182+ attrs, Ast_attributes. bs_this +> ty
183+ in
184+ name, attrs, Ast_util. to_method_type loc self " "
185+ (Ast_literal. type_unit ~loc () ) in
186+ let no ty =
187+ let attrs, core_type =
188+ match Ast_attributes. process_attributes_rev ptyp_attrs with
189+ | `Nothing , attrs -> attrs, ty
190+ | `Uncurry , attrs ->
191+ attrs, Ast_attributes. bs +> ty
192+ | `Method , attrs ->
193+ attrs, Ast_attributes. bs_method +> ty
194+ | `Meth_callback , attrs ->
195+ attrs, Ast_attributes. bs_this +> ty in
196+ label, attrs, self.typ self core_type in
197+ process_getter_setter ~no ~get ~set
198+ loc label ptyp_attrs core_type acc
199+ ) methods [] in
200+ let inner_type =
201+ { ty
202+ with ptyp_desc = Ptyp_object (new_methods, closed_flag);
203+ } in
204+ if ! record_as_js_object then
205+ Ast_comb. to_js_type loc inner_type
206+ else inner_type
207+ | _ -> super.typ self ty
208+
209+ let handle_class_type_fields self fields =
210+ Ext_list. fold_right
211+ (handle_class_type_field self)
212+ fields []
213+
214+ let handle_core_type self typ record_as_js_object =
215+ handle_core_type
216+ ~super: Bs_ast_mapper. default_mapper
217+ ~self typ record_as_js_object
0 commit comments