Skip to content

Commit bf9b986

Browse files
cristianoccristianoc
committed
Refactor maker and accessor generation in AST derive
Reworks the construction of maker function arguments and accessor value descriptions for type declarations. The maker function now accumulates argument types in a list and builds the final function type using Ast_helper.Typ.arrows. Accessor generation is clarified and setter types for mutable fields are constructed with explicit argument lists. This improves readability and maintainability of the code.
1 parent a4c05cc commit bf9b986

File tree

1 file changed

+73
-51
lines changed

1 file changed

+73
-51
lines changed

‎compiler/frontend/ast_derive_abstract.ml‎

Lines changed: 73 additions & 51 deletions
Original file line numberDiff line numberDiff line change
@@ -79,14 +79,16 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
7979
Ext_list.exists label_declarations (fun x ->
8080
Ast_attributes.has_bs_optional x.pld_attributes)
8181
in
82-
let setter_accessor, make_type, labels =
82+
let setter_accessor, maker_args, labels =
8383
Ext_list.fold_right label_declarations
8484
( [],
8585
(if has_optional_field then
86-
Ast_helper.Typ.arrow ~loc ~arity:None
87-
{attrs = []; lbl = Nolabel; typ = Ast_literal.type_unit ()}
88-
core_type
89-
else core_type),
86+
(* start with the implicit unit argument *)
87+
[
88+
({attrs = []; lbl = Nolabel; typ = Ast_literal.type_unit ()}
89+
: Parsetree.arg);
90+
]
91+
else []),
9092
[] )
9193
(fun ({
9294
pld_name = {txt = label_name; loc = label_loc} as pld_name;
@@ -106,61 +108,81 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
106108
let prim = [prim_as_name] in
107109
let is_optional = Ast_attributes.has_bs_optional pld_attributes in
108110

109-
let maker, acc =
110-
let arity =
111-
if List.length labels = List.length label_declarations - 1 then
112-
(* toplevel type *)
113-
Some ((if has_optional_field then 2 else 1) + List.length labels)
114-
else None
115-
in
111+
(* build the argument representing this field *)
112+
let field_arg =
113+
if is_optional then
114+
({attrs = []; lbl = Asttypes.Optional pld_name; typ = pld_type}
115+
: Parsetree.arg)
116+
else
117+
({attrs = []; lbl = Asttypes.Labelled pld_name; typ = pld_type}
118+
: Parsetree.arg)
119+
in
120+
121+
(* prepend to the maker argument list *)
122+
let maker_args = field_arg :: maker in
123+
124+
(* build accessor value description for this field *)
125+
let accessor_type =
116126
if is_optional then
117127
let optional_type = Ast_core_type.lift_option_type pld_type in
118-
( Ast_helper.Typ.arrow ~loc:pld_loc ~arity
119-
{attrs = []; lbl = Asttypes.Optional pld_name; typ = pld_type}
120-
maker,
121-
Val.mk ~loc:pld_loc
122-
(if light then pld_name
123-
else {pld_name with txt = pld_name.txt ^ "Get"})
124-
~attrs:get_optional_attrs ~prim
125-
(Ast_helper.Typ.arrow ~loc ~arity:(Some 1)
126-
{attrs = []; lbl = Nolabel; typ = core_type}
127-
optional_type)
128-
:: acc )
128+
Ast_helper.Typ.arrow ~loc ~arity:(Some 1)
129+
{attrs = []; lbl = Nolabel; typ = core_type}
130+
optional_type
129131
else
130-
( Ast_helper.Typ.arrow ~loc:pld_loc ~arity
131-
{attrs = []; lbl = Asttypes.Labelled pld_name; typ = pld_type}
132-
maker,
133-
Val.mk ~loc:pld_loc
134-
(if light then pld_name
135-
else {pld_name with txt = pld_name.txt ^ "Get"})
136-
~attrs:get_attrs
137-
~prim:
138-
((* Not needed actually*)
139-
External_ffi_types.ffi_bs_as_prims
140-
[External_arg_spec.dummy] Return_identity
141-
(Js_get {js_get_name = prim_as_name; js_get_scopes = []}))
142-
(Ast_helper.Typ.arrow ~loc ~arity:(Some 1)
143-
{attrs = []; lbl = Nolabel; typ = core_type}
144-
pld_type)
145-
:: acc )
132+
Ast_helper.Typ.arrow ~loc ~arity:(Some 1)
133+
{attrs = []; lbl = Nolabel; typ = core_type}
134+
pld_type
135+
in
136+
let accessor_prim =
137+
(* Not needed actually *)
138+
if is_optional then prim
139+
else
140+
External_ffi_types.ffi_bs_as_prims [External_arg_spec.dummy]
141+
Return_identity
142+
(Js_get {js_get_name = prim_as_name; js_get_scopes = []})
146143
in
147-
let is_current_field_mutable = pld_mutable = Mutable in
144+
let accessor_attrs =
145+
if is_optional then get_optional_attrs else get_attrs
146+
in
147+
148+
let accessor =
149+
Val.mk ~loc:pld_loc
150+
(if light then pld_name
151+
else {pld_name with txt = pld_name.txt ^ "Get"})
152+
~attrs:accessor_attrs ~prim:accessor_prim accessor_type
153+
in
154+
155+
(* accumulate *)
156+
let acc = accessor :: acc in
157+
158+
(* add setter for mutable fields *)
148159
let acc =
149-
if is_current_field_mutable then
160+
if pld_mutable = Mutable then
150161
let setter_type =
151-
Ast_helper.Typ.arrow ~arity:(Some 2)
152-
{attrs = []; lbl = Nolabel; typ = core_type}
153-
(Ast_helper.Typ.arrow ~arity:None
154-
{attrs = []; lbl = Nolabel; typ = pld_type} (* setter *)
155-
(Ast_literal.type_unit ()))
162+
Ast_helper.Typ.arrows ~loc:pld_loc
163+
[
164+
({attrs = []; lbl = Nolabel; typ = core_type}
165+
: Parsetree.arg);
166+
({attrs = []; lbl = Nolabel; typ = pld_type}
167+
: Parsetree.arg);
168+
]
169+
(Ast_literal.type_unit ())
170+
in
171+
let setter =
172+
Val.mk ~loc:pld_loc
173+
{loc = label_loc; txt = label_name ^ "Set"}
174+
~attrs:set_attrs ~prim setter_type
156175
in
157-
Val.mk ~loc:pld_loc
158-
{loc = label_loc; txt = label_name ^ "Set"} (* setter *)
159-
~attrs:set_attrs ~prim setter_type
160-
:: acc
176+
setter :: acc
161177
else acc
162178
in
163-
(acc, maker, (is_optional, new_label) :: labels))
179+
(acc, maker_args, (is_optional, new_label) :: labels))
180+
in
181+
(* build the final [make] function type from accumulated arguments *)
182+
let make_type =
183+
match maker_args with
184+
| [] -> core_type
185+
| args -> Ast_helper.Typ.arrows ~loc args core_type
164186
in
165187
( new_tdcl,
166188
if is_private then setter_accessor

0 commit comments

Comments
 (0)