Skip to content

Commit 8ff4713

Browse files
cristianoccristianoc
committed
Represent the arity of uncurried function definitions directly in the AST.
1 parent 55f12e0 commit 8ff4713

File tree

100 files changed

+1616
-1601
lines changed

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

100 files changed

+1616
-1601
lines changed

‎analysis/src/CompletionFrontEnd.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1318,7 +1318,7 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor
13181318
match exprToContextPath lhs with
13191319
| Some contextPath -> setResult (Cpath (CPObj (contextPath, label)))
13201320
| None -> ())
1321-
| Pexp_fun (lbl, defaultExpOpt, pat, e) ->
1321+
| Pexp_fun (lbl, defaultExpOpt, pat, e, _) ->
13221322
let oldScope = !scope in
13231323
(match (!processingFun, !currentCtxPath) with
13241324
| None, Some ctxPath -> processingFun := Some (ctxPath, 0)

‎analysis/src/DumpAst.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -213,7 +213,7 @@ and printExprItem expr ~pos ~indentation =
213213
| None -> ""
214214
| Some expr -> "," ^ printExprItem expr ~pos ~indentation)
215215
^ ")"
216-
| Pexp_fun (arg, _maybeDefaultArgExpr, pattern, nextExpr) ->
216+
| Pexp_fun (arg, _maybeDefaultArgExpr, pattern, nextExpr, _) ->
217217
"Pexp_fun(\n"
218218
^ addIndentation (indentation + 1)
219219
^ "arg: "

‎analysis/src/Xform.ml

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -261,7 +261,7 @@ module AddBracesToFn = struct
261261
| _ -> false
262262
in
263263
(match e.pexp_desc with
264-
| Pexp_fun (_, _, _, bodyExpr)
264+
| Pexp_fun (_, _, _, bodyExpr, _)
265265
when Loc.hasPos ~pos bodyExpr.pexp_loc
266266
&& isBracedExpr bodyExpr = false
267267
&& isFunction bodyExpr = false ->
@@ -303,10 +303,10 @@ module AddTypeAnnotation = struct
303303
in
304304
let rec processFunction ~argNum (e : Parsetree.expression) =
305305
match e.pexp_desc with
306-
| Pexp_fun (argLabel, _, pat, e)
306+
| Pexp_fun (argLabel, _, pat, e, _)
307307
| Pexp_construct
308308
( {txt = Lident "Function$"},
309-
Some {pexp_desc = Pexp_fun (argLabel, _, pat, e)} ) ->
309+
Some {pexp_desc = Pexp_fun (argLabel, _, pat, e, _)} ) ->
310310
let isUnlabeledOnlyArg =
311311
argNum = 1 && argLabel = Nolabel
312312
&&

‎compiler/frontend/ast_compatible.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -63,11 +63,11 @@ let app3 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 arg3 : expression =
6363
Pexp_apply (fn, [(Nolabel, arg1); (Nolabel, arg2); (Nolabel, arg3)]);
6464
}
6565

66-
let fun_ ?(loc = default_loc) ?(attrs = []) pat exp =
66+
let fun_ ?(loc = default_loc) ?(attrs = []) ~arity pat exp =
6767
{
6868
pexp_loc = loc;
6969
pexp_attributes = attrs;
70-
pexp_desc = Pexp_fun (Nolabel, None, pat, exp);
70+
pexp_desc = Pexp_fun (Nolabel, None, pat, exp, arity);
7171
}
7272

7373
let const_exp_string ?(loc = default_loc) ?(attrs = []) ?delimiter (s : string)

‎compiler/frontend/ast_compatible.mli

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -72,7 +72,12 @@ val apply_labels :
7272
*)
7373

7474
val fun_ :
75-
?loc:Location.t -> ?attrs:attrs -> pattern -> expression -> expression
75+
?loc:Location.t ->
76+
?attrs:attrs ->
77+
arity:int option ->
78+
pattern ->
79+
expression ->
80+
expression
7681

7782
(* val opt_label : string -> Asttypes.arg_label *)
7883

‎compiler/frontend/ast_derive_js_mapper.ml

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -167,7 +167,7 @@ let init () =
167167
in
168168
let to_js_body body =
169169
Ast_comb.single_non_rec_value pat_to_js
170-
(Ast_compatible.fun_
170+
(Ast_compatible.fun_ ~arity:None
171171
(Pat.constraint_ (Pat.var pat_param) core_type)
172172
body)
173173
in
@@ -211,7 +211,7 @@ let init () =
211211
in
212212
let from_js =
213213
Ast_comb.single_non_rec_value pat_from_js
214-
(Ast_compatible.fun_ (Pat.var pat_param)
214+
(Ast_compatible.fun_ ~arity:None (Pat.var pat_param)
215215
(if create_type then
216216
Exp.let_ Nonrecursive
217217
[Vb.mk (Pat.var pat_param) (exp_param +: new_type)]
@@ -253,7 +253,7 @@ let init () =
253253
app2 unsafe_index_get_exp exp_map exp_param
254254
else app1 erase_type_exp exp_param);
255255
Ast_comb.single_non_rec_value pat_from_js
256-
(Ast_compatible.fun_ (Pat.var pat_param)
256+
(Ast_compatible.fun_ ~arity:None (Pat.var pat_param)
257257
(let result =
258258
app2 unsafe_index_get_exp rev_exp_map exp_param
259259
in

‎compiler/frontend/ast_derive_projector.ml

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -46,7 +46,7 @@ let init () =
4646
->
4747
let txt = "param" in
4848
Ast_comb.single_non_rec_value ?attrs:gentype_attrs pld_name
49-
(Ast_compatible.fun_
49+
(Ast_compatible.fun_ ~arity:None
5050
(Pat.constraint_ (Pat.var {txt; loc}) core_type)
5151
(Exp.field
5252
(Exp.ident {txt = Lident txt; loc})
@@ -108,7 +108,9 @@ let init () =
108108
annotate_type
109109
in
110110
Ext_list.fold_right vars exp (fun var b ->
111-
Ast_compatible.fun_ (Pat.var {loc; txt = var}) b)
111+
Ast_compatible.fun_ ~arity:None
112+
(Pat.var {loc; txt = var})
113+
b)
112114
|> handle_uncurried_accessor_tranform ~loc ~arity))
113115
| Ptype_abstract | Ptype_open ->
114116
Ast_derive_util.not_applicable tdcl.ptype_loc deriving_name;

‎compiler/frontend/ast_pat.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -35,7 +35,7 @@ let is_unit_cont ~yes ~no (p : t) =
3535
let arity_of_fun (pat : Parsetree.pattern) (e : Parsetree.expression) =
3636
let rec aux (e : Parsetree.expression) =
3737
match e.pexp_desc with
38-
| Pexp_fun (_, _, _, e) -> 1 + aux e (*FIXME error on optional*)
38+
| Pexp_fun (_, _, _, e, _) -> 1 + aux e (*FIXME error on optional*)
3939
(* | Pexp_fun _
4040
-> Location.raise_errorf
4141
~loc:e.pexp_loc "Label is not allowed in JS object" *)
@@ -45,7 +45,7 @@ let arity_of_fun (pat : Parsetree.pattern) (e : Parsetree.expression) =
4545

4646
let rec labels_of_fun (e : Parsetree.expression) =
4747
match e.pexp_desc with
48-
| Pexp_fun (l, _, _, e) -> l :: labels_of_fun e
48+
| Pexp_fun (l, _, _, e, _) -> l :: labels_of_fun e
4949
| _ -> []
5050

5151
let rec is_single_variable_pattern_conservative (p : t) =

‎compiler/frontend/ast_uncurry_gen.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -36,7 +36,7 @@ let to_method_callback loc (self : Bs_ast_mapper.mapper) label
3636
match Ast_attributes.process_attributes_rev body.pexp_attributes with
3737
| Nothing, attrs -> (
3838
match body.pexp_desc with
39-
| Pexp_fun (arg_label, _, arg, body) ->
39+
| Pexp_fun (arg_label, _, arg, body, _) ->
4040
Bs_syntaxerr.optional_err loc arg_label;
4141
aux ((arg_label, self.pat self arg, attrs) :: acc) body
4242
| _ -> (self.expr self body, acc))
@@ -45,7 +45,7 @@ let to_method_callback loc (self : Bs_ast_mapper.mapper) label
4545
let result, rev_extra_args = aux [(label, self_pat, [])] body in
4646
let body =
4747
Ext_list.fold_left rev_extra_args result (fun e (label, p, attrs) ->
48-
Ast_helper.Exp.fun_ ~loc ~attrs label None p e)
48+
Ast_helper.Exp.fun_ ~loc ~attrs ~arity:None label None p e)
4949
in
5050
let arity = List.length rev_extra_args in
5151
let arity_s = string_of_int arity in

‎compiler/frontend/bs_ast_mapper.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -315,8 +315,8 @@ module E = struct
315315
sub vbs)
316316
(sub.expr sub e)
317317
(* #end *)
318-
| Pexp_fun (lab, def, p, e) ->
319-
fun_ ~loc ~attrs lab
318+
| Pexp_fun (lab, def, p, e, arity) ->
319+
fun_ ~loc ~attrs ~arity lab
320320
(map_opt (sub.expr sub) def)
321321
(sub.pat sub p) (sub.expr sub e)
322322
| Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)

‎compiler/frontend/bs_builtin_ppx.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -130,7 +130,7 @@ let expr_mapper ~async_context ~in_function_def (self : mapper)
130130
let body = Ast_async.add_async_attribute ~async body in
131131
let res = self.expr self body in
132132
{e with pexp_desc = Pexp_newtype (s, res)}
133-
| Pexp_fun (label, _, pat, body) -> (
133+
| Pexp_fun (label, _, pat, body, _arity) -> (
134134
let async = Ast_attributes.has_async_payload e.pexp_attributes <> None in
135135
match Ast_attributes.process_attributes_rev e.pexp_attributes with
136136
| Nothing, _ ->
@@ -594,7 +594,7 @@ let rec structure_mapper ~await_context (self : mapper) (stru : Ast_structure.t)
594594
| Pexp_ifthenelse (_, then_expr, Some else_expr) ->
595595
aux then_expr @ aux else_expr
596596
| Pexp_construct (_, Some expr) -> aux expr
597-
| Pexp_fun (_, _, _, expr) | Pexp_newtype (_, expr) -> aux expr
597+
| Pexp_fun (_, _, _, expr, _) | Pexp_newtype (_, expr) -> aux expr
598598
| _ -> acc
599599
in
600600
aux pvb_expr @ spelunk_vbs acc tl

‎compiler/ml/ast_async.ml

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -40,14 +40,14 @@ let add_async_attribute ~async (body : Parsetree.expression) =
4040

4141
let rec add_promise_to_result ~loc (e : Parsetree.expression) =
4242
match e.pexp_desc with
43-
| Pexp_fun (label, eo, pat, body) ->
43+
| Pexp_fun (label, eo, pat, body, arity) ->
4444
let body = add_promise_to_result ~loc body in
45-
{e with pexp_desc = Pexp_fun (label, eo, pat, body)}
45+
{e with pexp_desc = Pexp_fun (label, eo, pat, body, arity)}
4646
| _ -> add_promise_type ~loc ~async:true e
4747

4848
let make_function_async ~async (e : Parsetree.expression) =
4949
if async then
5050
match e.pexp_desc with
51-
| Pexp_fun (_, _, {ppat_loc}, _) -> add_promise_to_result ~loc:ppat_loc e
51+
| Pexp_fun (_, _, {ppat_loc}, _, _) -> add_promise_to_result ~loc:ppat_loc e
5252
| _ -> assert false
5353
else e

‎compiler/ml/ast_helper.ml

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -150,7 +150,8 @@ module Exp = struct
150150
let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a)
151151
let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a)
152152
let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c))
153-
let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d))
153+
let fun_ ?loc ?attrs ~arity a b c d =
154+
mk ?loc ?attrs (Pexp_fun (a, b, c, d, arity))
154155
let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a)
155156
let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b))
156157
let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b))

‎compiler/ml/ast_helper.mli

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -132,6 +132,7 @@ module Exp : sig
132132
val fun_ :
133133
?loc:loc ->
134134
?attrs:attrs ->
135+
arity:int option ->
135136
arg_label ->
136137
expression option ->
137138
pattern ->

‎compiler/ml/ast_iterator.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -282,7 +282,7 @@ module E = struct
282282
| Pexp_let (_r, vbs, e) ->
283283
List.iter (sub.value_binding sub) vbs;
284284
sub.expr sub e
285-
| Pexp_fun (_lab, def, p, e) ->
285+
| Pexp_fun (_lab, def, p, e, _) ->
286286
iter_opt (sub.expr sub) def;
287287
sub.pat sub p;
288288
sub.expr sub e

‎compiler/ml/ast_mapper.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -278,8 +278,8 @@ module E = struct
278278
| Pexp_constant x -> constant ~loc ~attrs x
279279
| Pexp_let (r, vbs, e) ->
280280
let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e)
281-
| Pexp_fun (lab, def, p, e) ->
282-
fun_ ~loc ~attrs lab
281+
| Pexp_fun (lab, def, p, e, arity) ->
282+
fun_ ~loc ~attrs ~arity lab
283283
(map_opt (sub.expr sub) def)
284284
(sub.pat sub p) (sub.expr sub e)
285285
| Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)

‎compiler/ml/ast_mapper_from0.ml

Lines changed: 37 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -285,7 +285,7 @@ module E = struct
285285
| Pexp_let (r, vbs, e) ->
286286
let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e)
287287
| Pexp_fun (lab, def, p, e) ->
288-
fun_ ~loc ~attrs lab
288+
fun_ ~loc ~attrs ~arity:None lab
289289
(map_opt (sub.expr sub) def)
290290
(sub.pat sub p) (sub.expr sub e)
291291
| Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)
@@ -295,8 +295,42 @@ module E = struct
295295
match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
296296
| Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
297297
| Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
298-
| Pexp_construct (lid, arg) ->
299-
construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
298+
| Pexp_construct (lid, arg) -> (
299+
let lid1 = map_loc sub lid in
300+
let arg1 = map_opt (sub.expr sub) arg in
301+
let exp1 = construct ~loc ~attrs lid1 arg1 in
302+
match lid.txt with
303+
| Lident "Function$" -> (
304+
let rec attributes_to_arity (attrs : Parsetree.attributes) =
305+
match attrs with
306+
| ( {txt = "res.arity"},
307+
PStr
308+
[
309+
{
310+
pstr_desc =
311+
Pstr_eval
312+
( {pexp_desc = Pexp_constant (Pconst_integer (arity, _))},
313+
_ );
314+
};
315+
] )
316+
:: _ ->
317+
int_of_string arity
318+
| _ :: rest -> attributes_to_arity rest
319+
| [] -> assert false
320+
in
321+
match arg1 with
322+
| Some ({pexp_desc = Pexp_fun (l, eo, p, e, _)} as e1) ->
323+
let arity = attributes_to_arity attrs in
324+
{
325+
e1 with
326+
pexp_desc =
327+
Pexp_construct
328+
( lid1,
329+
Some {e with pexp_desc = Pexp_fun (l, eo, p, e, Some arity)}
330+
);
331+
}
332+
| _ -> exp1)
333+
| _ -> exp1)
300334
| Pexp_variant (lab, eo) ->
301335
variant ~loc ~attrs lab (map_opt (sub.expr sub) eo)
302336
| Pexp_record (l, eo) ->

‎compiler/ml/ast_mapper_to0.ml

Lines changed: 26 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -283,7 +283,7 @@ module E = struct
283283
| Pexp_constant x -> constant ~loc ~attrs (map_constant x)
284284
| Pexp_let (r, vbs, e) ->
285285
let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e)
286-
| Pexp_fun (lab, def, p, e) ->
286+
| Pexp_fun (lab, def, p, e, _) ->
287287
fun_ ~loc ~attrs lab
288288
(map_opt (sub.expr sub) def)
289289
(sub.pat sub p) (sub.expr sub e)
@@ -294,8 +294,31 @@ module E = struct
294294
match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
295295
| Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
296296
| Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
297-
| Pexp_construct (lid, arg) ->
298-
construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
297+
| Pexp_construct (lid, arg) -> (
298+
let exp0 =
299+
construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
300+
in
301+
match lid.txt with
302+
| Lident "Function$" -> (
303+
match arg with
304+
| Some {pexp_desc = Pexp_fun (_, _, _, _, Some arity)} ->
305+
let arity_to_attributes arity =
306+
[
307+
( Location.mknoloc "res.arity",
308+
Parsetree0.PStr
309+
[
310+
Ast_helper0.Str.eval
311+
(Ast_helper0.Exp.constant
312+
(Pconst_integer (string_of_int arity, None)));
313+
] );
314+
]
315+
in
316+
{
317+
exp0 with
318+
pexp_attributes = arity_to_attributes arity @ exp0.pexp_attributes;
319+
}
320+
| _ -> assert false)
321+
| _ -> exp0)
299322
| Pexp_variant (lab, eo) ->
300323
variant ~loc ~attrs lab (map_opt (sub.expr sub) eo)
301324
| Pexp_record (l, eo) ->

‎compiler/ml/ast_uncurried.ml

Lines changed: 13 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -19,36 +19,14 @@ let uncurried_type ~loc ~arity t_arg =
1919
let t_arity = arity_type ~loc arity in
2020
Ast_helper.Typ.constr ~loc {txt = Lident "function$"; loc} [t_arg; t_arity]
2121

22-
let arity_to_attributes arity =
23-
[
24-
( Location.mknoloc "res.arity",
25-
Parsetree.PStr
26-
[
27-
Ast_helper.Str.eval
28-
(Ast_helper.Exp.constant
29-
(Pconst_integer (string_of_int arity, None)));
30-
] );
31-
]
32-
33-
let rec attributes_to_arity (attrs : Parsetree.attributes) =
34-
match attrs with
35-
| ( {txt = "res.arity"},
36-
PStr
37-
[
38-
{
39-
pstr_desc =
40-
Pstr_eval
41-
({pexp_desc = Pexp_constant (Pconst_integer (arity, _))}, _);
42-
};
43-
] )
44-
:: _ ->
45-
int_of_string arity
46-
| _ :: rest -> attributes_to_arity rest
47-
| _ -> assert false
48-
4922
let uncurried_fun ~loc ~arity fun_expr =
23+
let fun_expr =
24+
match fun_expr.Parsetree.pexp_desc with
25+
| Pexp_fun (l, eo, p, e, _) ->
26+
{fun_expr with pexp_desc = Pexp_fun (l, eo, p, e, Some arity)}
27+
| _ -> assert false
28+
in
5029
Ast_helper.Exp.construct ~loc
51-
~attrs:(arity_to_attributes arity)
5230
(Location.mknoloc (Longident.Lident "Function$"))
5331
(Some fun_expr)
5432

@@ -59,7 +37,13 @@ let expr_is_uncurried_fun (expr : Parsetree.expression) =
5937

6038
let expr_extract_uncurried_fun (expr : Parsetree.expression) =
6139
match expr.pexp_desc with
62-
| Pexp_construct ({txt = Lident "Function$"}, Some e) -> e
40+
| Pexp_construct ({txt = Lident "Function$"}, Some e) ->
41+
let () =
42+
match e.pexp_desc with
43+
| Pexp_fun (_, _, _, _, Some _arity) -> ()
44+
| _ -> assert false
45+
in
46+
e
6347
| _ -> assert false
6448

6549
let core_type_is_uncurried_fun (typ : Parsetree.core_type) =

‎compiler/ml/depend.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -218,7 +218,7 @@ let rec add_expr bv exp =
218218
| Pexp_let (rf, pel, e) ->
219219
let bv = add_bindings rf bv pel in
220220
add_expr bv e
221-
| Pexp_fun (_, opte, p, e) ->
221+
| Pexp_fun (_, opte, p, e, _) ->
222222
add_opt add_expr bv opte;
223223
add_expr (add_pattern bv p) e
224224
| Pexp_function pel -> add_cases bv pel

0 commit comments

Comments
 (0)