Skip to content

Commit efc80bd

Browse files
cristianoccristianoc
committed
AST: store the attributes directly on function arguments.
Functions of several arguments are stored as nested `Ptyp_arrow` ast nodes, with attributes at toplevel in the node. This change adds an attribute field to type arguments, makin it impossible to distinguish attributes on arguments from attributes on the entire function.
1 parent caf4154 commit efc80bd

File tree

17 files changed

+90
-92
lines changed

17 files changed

+90
-92
lines changed

‎compiler/frontend/ast_core_type.ml

Lines changed: 4 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -95,7 +95,7 @@ let from_labels ~loc arity labels : t =
9595
in
9696
let args =
9797
Ext_list.map2 labels tyvars (fun label tyvar ->
98-
{Parsetree.lbl = Asttypes.Labelled label; typ = tyvar})
98+
{Parsetree.attrs = []; lbl = Asttypes.Labelled label; typ = tyvar})
9999
in
100100
Typ.arrows ~loc args result_type
101101

@@ -143,7 +143,8 @@ let mk_fn_type (new_arg_types_ty : param_type list) (result : t) : t =
143143
Ext_list.fold_right new_arg_types_ty result
144144
(fun {label; ty; attr; loc} acc ->
145145
Ast_helper.Typ.arrow ~loc ~attrs:attr ~arity:None
146-
{lbl = label; typ = ty} acc)
146+
{attrs = []; lbl = label; typ = ty}
147+
acc)
147148
in
148149
match t.ptyp_desc with
149150
| Ptyp_arrow arr ->
@@ -156,12 +157,7 @@ let list_of_arrow (ty : t) : t * param_type list =
156157
match ty.ptyp_desc with
157158
| Ptyp_arrow {arg; ret; arity} when arity = None || acc = [] ->
158159
aux ret
159-
(({
160-
label = arg.lbl;
161-
ty = arg.typ;
162-
attr = ty.ptyp_attributes;
163-
loc = ty.ptyp_loc;
164-
}
160+
(({label = arg.lbl; ty = arg.typ; attr = arg.attrs; loc = ty.ptyp_loc}
165161
: param_type)
166162
:: acc)
167163
| Ptyp_poly (_, ty) ->

‎compiler/frontend/ast_derive_abstract.ml

Lines changed: 7 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -84,7 +84,7 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
8484
( [],
8585
(if has_optional_field then
8686
Ast_helper.Typ.arrow ~loc ~arity:None
87-
{lbl = Nolabel; typ = Ast_literal.type_unit ()}
87+
{attrs = []; lbl = Nolabel; typ = Ast_literal.type_unit ()}
8888
core_type
8989
else core_type),
9090
[] )
@@ -116,19 +116,19 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
116116
if is_optional then
117117
let optional_type = Ast_core_type.lift_option_type pld_type in
118118
( Ast_helper.Typ.arrow ~loc:pld_loc ~arity
119-
{lbl = Asttypes.Optional pld_name; typ = pld_type}
119+
{attrs = []; lbl = Asttypes.Optional pld_name; typ = pld_type}
120120
maker,
121121
Val.mk ~loc:pld_loc
122122
(if light then pld_name
123123
else {pld_name with txt = pld_name.txt ^ "Get"})
124124
~attrs:get_optional_attrs ~prim
125125
(Ast_helper.Typ.arrow ~loc ~arity:(Some 1)
126-
{lbl = Nolabel; typ = core_type}
126+
{attrs = []; lbl = Nolabel; typ = core_type}
127127
optional_type)
128128
:: acc )
129129
else
130130
( Ast_helper.Typ.arrow ~loc:pld_loc ~arity
131-
{lbl = Asttypes.Labelled pld_name; typ = pld_type}
131+
{attrs = []; lbl = Asttypes.Labelled pld_name; typ = pld_type}
132132
maker,
133133
Val.mk ~loc:pld_loc
134134
(if light then pld_name
@@ -140,7 +140,7 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
140140
[External_arg_spec.dummy] Return_identity
141141
(Js_get {js_get_name = prim_as_name; js_get_scopes = []}))
142142
(Ast_helper.Typ.arrow ~loc ~arity:(Some 1)
143-
{lbl = Nolabel; typ = core_type}
143+
{attrs = []; lbl = Nolabel; typ = core_type}
144144
pld_type)
145145
:: acc )
146146
in
@@ -149,9 +149,9 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
149149
if is_current_field_mutable then
150150
let setter_type =
151151
Ast_helper.Typ.arrow ~arity:(Some 2)
152-
{lbl = Nolabel; typ = core_type}
152+
{attrs = []; lbl = Nolabel; typ = core_type}
153153
(Ast_helper.Typ.arrow ~arity:None
154-
{lbl = Nolabel; typ = pld_type} (* setter *)
154+
{attrs = []; lbl = Nolabel; typ = pld_type} (* setter *)
155155
(Ast_literal.type_unit ()))
156156
in
157157
Val.mk ~loc:pld_loc

‎compiler/frontend/ast_derive_js_mapper.ml

Lines changed: 10 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -69,7 +69,9 @@ let erase_type_str =
6969
Str.primitive
7070
(Val.mk ~prim:["%identity"]
7171
{loc = noloc; txt = erase_type_lit}
72-
(Ast_helper.Typ.arrow ~arity:(Some 1) {lbl = Nolabel; typ = any} any))
72+
(Ast_helper.Typ.arrow ~arity:(Some 1)
73+
{attrs = []; lbl = Nolabel; typ = any}
74+
any))
7375

7476
let unsafe_index = "_index"
7577

@@ -79,8 +81,11 @@ let unsafe_index_get =
7981
(Val.mk ~prim:[""]
8082
{loc = noloc; txt = unsafe_index}
8183
~attrs:[Ast_attributes.get_index]
82-
(Ast_helper.Typ.arrow ~arity:None {lbl = Nolabel; typ = any}
83-
(Ast_helper.Typ.arrow ~arity:None {lbl = Nolabel; typ = any} any)))
84+
(Ast_helper.Typ.arrow ~arity:None
85+
{attrs = []; lbl = Nolabel; typ = any}
86+
(Ast_helper.Typ.arrow ~arity:None
87+
{attrs = []; lbl = Nolabel; typ = any}
88+
any)))
8489

8590
let unsafe_index_get_exp = Exp.ident {loc = noloc; txt = Lident unsafe_index}
8691

@@ -132,7 +137,7 @@ let app1 = Ast_compatible.app1
132137
let app2 = Ast_compatible.app2
133138

134139
let ( ->~ ) a b =
135-
Ast_helper.Typ.arrow ~arity:(Some 1) {lbl = Nolabel; typ = a} b
140+
Ast_helper.Typ.arrow ~arity:(Some 1) {attrs = []; lbl = Nolabel; typ = a} b
136141

137142
let raise_when_not_found_ident =
138143
Longident.Ldot (Lident Primitive_modules.util, "raiseWhenNotFound")
@@ -305,7 +310,7 @@ let init () =
305310
let to_js_type result =
306311
Ast_comb.single_non_rec_val pat_to_js
307312
(Ast_helper.Typ.arrow ~arity:(Some 1)
308-
{lbl = Nolabel; typ = core_type}
313+
{attrs = []; lbl = Nolabel; typ = core_type}
309314
result)
310315
in
311316
let new_type, new_tdcl =

‎compiler/frontend/ast_derive_projector.ml

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -137,7 +137,7 @@ let init () =
137137
Ext_list.map label_declarations (fun {pld_name; pld_type} ->
138138
Ast_comb.single_non_rec_val ?attrs:gentype_attrs pld_name
139139
(Ast_helper.Typ.arrow ~arity:(Some 1)
140-
{lbl = Nolabel; typ = core_type}
140+
{attrs = []; lbl = Nolabel; typ = core_type}
141141
pld_type
142142
(*arity will alwys be 1 since these are single param functions*)))
143143
| Ptype_variant constructor_declarations ->
@@ -170,7 +170,8 @@ let init () =
170170
{loc; txt = Ext_string.uncapitalize_ascii con_name}
171171
(Ext_list.fold_right pcd_args annotate_type (fun x acc ->
172172
Ast_helper.Typ.arrow ~arity:None
173-
{lbl = Nolabel; typ = x} acc)
173+
{attrs = []; lbl = Nolabel; typ = x}
174+
acc)
174175
|> add_arity ~arity))
175176
| Ptype_open | Ptype_abstract ->
176177
Ast_derive_util.not_applicable tdcl.ptype_loc deriving_name;

‎compiler/frontend/ast_exp_handle_external.ml

Lines changed: 13 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -43,7 +43,7 @@ let handle_external loc (x : string) : Parsetree.expression =
4343
Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
4444
~pval_type:
4545
(Ast_helper.Typ.arrow ~arity:(Some 1)
46-
{lbl = Nolabel; typ = Ast_helper.Typ.any ()}
46+
{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}
4747
(Ast_helper.Typ.any ()))
4848
[str_exp];
4949
}
@@ -72,7 +72,7 @@ let handle_debugger loc (payload : Ast_payload.t) =
7272
Ast_external_mk.local_external_apply loc ~pval_prim:["%debugger"]
7373
~pval_type:
7474
(Ast_helper.Typ.arrow ~arity:(Some 1)
75-
{lbl = Nolabel; typ = Ast_helper.Typ.any ()}
75+
{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}
7676
(Ast_literal.type_unit ()))
7777
[Ast_literal.val_unit ~loc ()]
7878
| _ ->
@@ -99,7 +99,7 @@ let handle_raw ~kind loc payload =
9999
Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
100100
~pval_type:
101101
(Ast_helper.Typ.arrow ~arity:(Some 1)
102-
{lbl = Nolabel; typ = Ast_helper.Typ.any ()}
102+
{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}
103103
(Ast_helper.Typ.any ()))
104104
[exp];
105105
pexp_attributes =
@@ -128,11 +128,16 @@ let handle_ffi ~loc ~payload =
128128
let unit = Ast_literal.type_unit ~loc () in
129129
let rec arrow ~arity =
130130
if arity = 0 then
131-
Ast_helper.Typ.arrow ~arity:None ~loc {lbl = Nolabel; typ = unit} any
131+
Ast_helper.Typ.arrow ~arity:None ~loc
132+
{attrs = []; lbl = Nolabel; typ = unit}
133+
any
132134
else if arity = 1 then
133-
Ast_helper.Typ.arrow ~arity:None ~loc {lbl = Nolabel; typ = any} any
135+
Ast_helper.Typ.arrow ~arity:None ~loc
136+
{attrs = []; lbl = Nolabel; typ = any}
137+
any
134138
else
135-
Ast_helper.Typ.arrow ~loc ~arity:None {lbl = Nolabel; typ = any}
139+
Ast_helper.Typ.arrow ~loc ~arity:None
140+
{attrs = []; lbl = Nolabel; typ = any}
136141
(arrow ~arity:(arity - 1))
137142
in
138143
match !is_function with
@@ -152,7 +157,7 @@ let handle_ffi ~loc ~payload =
152157
Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
153158
~pval_type:
154159
(Ast_helper.Typ.arrow ~arity:(Some 1)
155-
{lbl = Nolabel; typ = Ast_helper.Typ.any ()}
160+
{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}
156161
(Ast_helper.Typ.any ()))
157162
[exp];
158163
pexp_attributes =
@@ -171,7 +176,7 @@ let handle_raw_structure loc payload =
171176
Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_stmt"]
172177
~pval_type:
173178
(Ast_helper.Typ.arrow ~arity:(Some 1)
174-
{lbl = Nolabel; typ = Ast_helper.Typ.any ()}
179+
{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}
175180
(Ast_helper.Typ.any ()))
176181
[exp];
177182
}

‎compiler/frontend/ast_typ_uncurry.ml

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -32,7 +32,9 @@ let to_method_callback_type loc (mapper : Bs_ast_mapper.mapper)
3232
let first_arg = mapper.typ mapper first_arg in
3333
let typ = mapper.typ mapper typ in
3434
let meth_type =
35-
Ast_helper.Typ.arrow ~loc ~arity:None {lbl = label; typ = first_arg} typ
35+
Ast_helper.Typ.arrow ~loc ~arity:None
36+
{attrs = []; lbl = label; typ = first_arg}
37+
typ
3638
in
3739
let arity = Ast_core_type.get_uncurry_arity meth_type in
3840
match arity with
@@ -58,7 +60,9 @@ let to_uncurry_type loc (mapper : Bs_ast_mapper.mapper)
5860
let typ = mapper.typ mapper typ in
5961

6062
let fn_type =
61-
Ast_helper.Typ.arrow ~loc ~arity:None {lbl = label; typ = first_arg} typ
63+
Ast_helper.Typ.arrow ~loc ~arity:None
64+
{attrs = []; lbl = label; typ = first_arg}
65+
typ
6266
in
6367
let arity = Ast_core_type.get_uncurry_arity fn_type in
6468
let fn_type =

‎compiler/ml/ast_mapper_from0.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -99,8 +99,8 @@ module T = struct
9999
| Ptyp_var s -> Typ.var ~loc ~attrs s
100100
| Ptyp_arrow (lbl, t1, t2) ->
101101
let lbl = Asttypes.to_arg_label lbl in
102-
Typ.arrow ~loc ~attrs ~arity:None
103-
{lbl; typ = sub.typ sub t1}
102+
Typ.arrow ~loc ~arity:None
103+
{attrs; lbl; typ = sub.typ sub t1}
104104
(sub.typ sub t2)
105105
| Ptyp_tuple tyl -> Typ.tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
106106
| Ptyp_constr (lid, tl) -> (

‎compiler/ml/parsetree.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -73,7 +73,7 @@ and core_type = {
7373
ptyp_attributes: attributes; (* ... [@id1] [@id2] *)
7474
}
7575

76-
and arg = {lbl: arg_label; typ: core_type}
76+
and arg = {attrs: attributes; lbl: arg_label; typ: core_type}
7777

7878
and core_type_desc =
7979
| Ptyp_any (* _ *)

‎compiler/ml/pprintast.ml

Lines changed: 10 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -285,11 +285,15 @@ let tyvar f str = pp f "'%s" str
285285
let tyvar_loc f str = pp f "'%s" str.txt
286286
let string_quot f x = pp f "`%s" x
287287

288-
let rec type_with_label ctxt f (label, c) =
289-
match label with
290-
| Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *)
291-
| Labelled {txt = s} -> pp f "%s:%a" s (core_type1 ctxt) c
292-
| Optional {txt = s} -> pp f "?%s:%a" s (core_type1 ctxt) c
288+
let rec type_with_label ctxt f arg =
289+
match arg.lbl with
290+
| Nolabel ->
291+
pp f "%a%a" (core_type1 ctxt) arg.typ (attributes ctxt) arg.attrs
292+
(* otherwise parenthesize *)
293+
| Labelled {txt = s} ->
294+
pp f "%s:%a%a" s (core_type1 ctxt) arg.typ (attributes ctxt) arg.attrs
295+
| Optional {txt = s} ->
296+
pp f "?%s:%a%a" s (core_type1 ctxt) arg.typ (attributes ctxt) arg.attrs
293297

294298
and core_type ctxt f x =
295299
if x.ptyp_attributes <> [] then
@@ -300,7 +304,7 @@ and core_type ctxt f x =
300304
match x.ptyp_desc with
301305
| Ptyp_arrow {arg; ret; arity} ->
302306
pp f "@[<2>%a@;->@;%a%s@]" (* FIXME remove parens later *)
303-
(type_with_label ctxt) (arg.lbl, arg.typ) (core_type ctxt) ret
307+
(type_with_label ctxt) arg (core_type ctxt) ret
304308
(match arity with
305309
| None -> ""
306310
| Some n -> " (a:" ^ string_of_int n ^ ")")

‎compiler/syntax/src/jsx_v4.ml

Lines changed: 5 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -918,20 +918,16 @@ let transform_structure_item ~config item =
918918
|> Option.map Jsx_common.typ_vars_of_core_type
919919
|> Option.value ~default:[]
920920
in
921-
let rec get_prop_types types
922-
({ptyp_loc; ptyp_desc; ptyp_attributes} as full_type) =
921+
let rec get_prop_types types ({ptyp_loc; ptyp_desc} as full_type) =
923922
match ptyp_desc with
924923
| Ptyp_arrow {arg; ret = {ptyp_desc = Ptyp_arrow _} as typ2}
925924
when is_labelled arg.lbl || is_optional arg.lbl ->
926-
get_prop_types
927-
((arg.lbl, ptyp_attributes, ptyp_loc, arg.typ) :: types)
928-
typ2
925+
get_prop_types ((arg.lbl, arg.attrs, ptyp_loc, arg.typ) :: types) typ2
929926
| Ptyp_arrow {arg = {lbl = Nolabel}; ret} -> get_prop_types types ret
930927
| Ptyp_arrow {arg; ret = return_value}
931928
when is_labelled arg.lbl || is_optional arg.lbl ->
932929
( return_value,
933-
(arg.lbl, ptyp_attributes, return_value.ptyp_loc, arg.typ) :: types
934-
)
930+
(arg.lbl, arg.attrs, return_value.ptyp_loc, arg.typ) :: types )
935931
| _ -> (full_type, types)
936932
in
937933
let inner_type, prop_types = get_prop_types [] pval_type in
@@ -1027,9 +1023,7 @@ let transform_signature_item ~config item =
10271023
match ptyp_desc with
10281024
| Ptyp_arrow {arg; ret = {ptyp_desc = Ptyp_arrow _} as rest}
10291025
when is_optional arg.lbl || is_labelled arg.lbl ->
1030-
get_prop_types
1031-
((arg.lbl, arg.typ.ptyp_attributes, ptyp_loc, arg.typ) :: types)
1032-
rest
1026+
get_prop_types ((arg.lbl, arg.attrs, ptyp_loc, arg.typ) :: types) rest
10331027
| Ptyp_arrow
10341028
{
10351029
arg =
@@ -1045,8 +1039,7 @@ let transform_signature_item ~config item =
10451039
| Ptyp_arrow {arg; ret = return_value}
10461040
when is_optional arg.lbl || is_labelled arg.lbl ->
10471041
( return_value,
1048-
(arg.lbl, arg.typ.ptyp_attributes, return_value.ptyp_loc, arg.typ)
1049-
:: types )
1042+
(arg.lbl, arg.attrs, return_value.ptyp_loc, arg.typ) :: types )
10501043
| _ -> (full_type, types)
10511044
in
10521045
let inner_type, prop_types = get_prop_types [] pval_type in

0 commit comments

Comments
 (0)