Skip to content

Commit ba78715

Browse files
cristianoccristianoc
authored
Represent the arity of uncurried function definitions directly in the… (#7197)
* Represent the arity of uncurried function definitions directly in the AST. * Use uncurried type for `@deriving(jsConverter)` This goes towards making all arities explicit. * Clean up arity in derive projector. The arity is later overridden anyway, but being explicit can help cleaning up later on if `Function$` is removed entirely. * Most of Untypeast is never used. * More explicit translation for `Function$`. Cosmetic change that will be needed later to remove `Function$`. * Update CHANGELOG.md
1 parent 55f12e0 commit ba78715

File tree

104 files changed

+1643
-2229
lines changed

Some content is hidden

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

104 files changed

+1643
-2229
lines changed

‎CHANGELOG.md

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,7 @@
2323
- Ast cleanup: remove exp object and exp unreachable. https://github.com/rescript-lang/rescript/pull/7189
2424
- Ast cleanup: explicit representation for optional record fields in types. https://github.com/rescript-lang/rescript/pull/7190 https://github.com/rescript-lang/rescript/pull/7191
2525
- AST cleanup: first-class expression and patterns for records with optional fields. https://github.com/rescript-lang/rescript/pull/7192
26+
- AST cleanup: Represent the arity of uncurried function definitions directly in the AST. https://github.com/rescript-lang/rescript/pull/7197
2627

2728

2829
# 12.0.0-alpha.5

‎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: 27 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -128,7 +128,9 @@ let app1 = Ast_compatible.app1
128128

129129
let app2 = Ast_compatible.app2
130130

131-
let ( ->~ ) a b = Ast_compatible.arrow a b
131+
let ( ->~ ) a b =
132+
Ast_uncurried.uncurried_type ~loc:Location.none ~arity:1
133+
(Ast_compatible.arrow a b)
132134

133135
let raise_when_not_found_ident =
134136
Longident.Ldot (Lident Primitive_modules.util, "raiseWhenNotFound")
@@ -167,9 +169,10 @@ let init () =
167169
in
168170
let to_js_body body =
169171
Ast_comb.single_non_rec_value pat_to_js
170-
(Ast_compatible.fun_
171-
(Pat.constraint_ (Pat.var pat_param) core_type)
172-
body)
172+
(Ast_uncurried.uncurried_fun ~loc:Location.none ~arity:1
173+
(Ast_compatible.fun_ ~arity:None
174+
(Pat.constraint_ (Pat.var pat_param) core_type)
175+
body))
173176
in
174177
let ( +> ) a ty = Exp.constraint_ (erase_type a) ty in
175178
let ( +: ) a ty = erase_type (Exp.constraint_ a ty) in
@@ -211,12 +214,16 @@ let init () =
211214
in
212215
let from_js =
213216
Ast_comb.single_non_rec_value pat_from_js
214-
(Ast_compatible.fun_ (Pat.var pat_param)
215-
(if create_type then
216-
Exp.let_ Nonrecursive
217-
[Vb.mk (Pat.var pat_param) (exp_param +: new_type)]
218-
(Exp.constraint_ obj_exp core_type)
219-
else Exp.constraint_ obj_exp core_type))
217+
(Ast_uncurried.uncurried_fun ~loc:Location.none ~arity:1
218+
(Ast_compatible.fun_ ~arity:(Some 1) (Pat.var pat_param)
219+
(if create_type then
220+
Exp.let_ Nonrecursive
221+
[
222+
Vb.mk (Pat.var pat_param)
223+
(exp_param +: new_type);
224+
]
225+
(Exp.constraint_ obj_exp core_type)
226+
else Exp.constraint_ obj_exp core_type)))
220227
in
221228
let rest = [to_js; from_js] in
222229
if create_type then erase_type_str :: new_type_str :: rest
@@ -253,12 +260,14 @@ let init () =
253260
app2 unsafe_index_get_exp exp_map exp_param
254261
else app1 erase_type_exp exp_param);
255262
Ast_comb.single_non_rec_value pat_from_js
256-
(Ast_compatible.fun_ (Pat.var pat_param)
257-
(let result =
258-
app2 unsafe_index_get_exp rev_exp_map exp_param
259-
in
260-
if create_type then raise_when_not_found result
261-
else result));
263+
(Ast_uncurried.uncurried_fun ~loc:Location.none ~arity:1
264+
(Ast_compatible.fun_ ~arity:(Some 1)
265+
(Pat.var pat_param)
266+
(let result =
267+
app2 unsafe_index_get_exp rev_exp_map exp_param
268+
in
269+
if create_type then raise_when_not_found result
270+
else result)));
262271
]
263272
in
264273
if create_type then new_type_str :: v else v
@@ -285,7 +294,8 @@ let init () =
285294
let pat_from_js = {Asttypes.loc; txt = from_js} in
286295
let to_js_type result =
287296
Ast_comb.single_non_rec_val pat_to_js
288-
(Ast_compatible.arrow core_type result)
297+
(Ast_uncurried.uncurried_type ~loc:Location.none ~arity:1
298+
(Ast_compatible.arrow core_type result))
289299
in
290300
let new_type, new_tdcl =
291301
U.new_type_of_type_declaration tdcl ("abs_" ^ name)

‎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:(Some 1)
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:(Some 1)
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) ->

0 commit comments

Comments
 (0)