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

Author: cristianoc

CHANGELOG.md

@@ -23,6 +23,7 @@
 - Ast cleanup: remove exp object and exp unreachable. https://github.com/rescript-lang/rescript/pull/7189
 - 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
 - AST cleanup: first-class expression and patterns for records with optional fields. https://github.com/rescript-lang/rescript/pull/7192
+- AST cleanup: Represent the arity of uncurried function definitions directly in the AST. https://github.com/rescript-lang/rescript/pull/7197
 
 
 # 12.0.0-alpha.5

analysis/src/CompletionFrontEnd.ml

@@ -1318,7 +1318,7 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor
             match exprToContextPath lhs with
             | Some contextPath -> setResult (Cpath (CPObj (contextPath, label)))
             | None -> ())
-        | Pexp_fun (lbl, defaultExpOpt, pat, e) ->
+        | Pexp_fun (lbl, defaultExpOpt, pat, e, _) ->
           let oldScope = !scope in
           (match (!processingFun, !currentCtxPath) with
           | None, Some ctxPath -> processingFun := Some (ctxPath, 0)

analysis/src/DumpAst.ml

@@ -213,7 +213,7 @@ and printExprItem expr ~pos ~indentation =
       | None -> ""
       | Some expr -> "," ^ printExprItem expr ~pos ~indentation)
     ^ ")"
-  | Pexp_fun (arg, _maybeDefaultArgExpr, pattern, nextExpr) ->
+  | Pexp_fun (arg, _maybeDefaultArgExpr, pattern, nextExpr, _) ->
     "Pexp_fun(\n"
     ^ addIndentation (indentation + 1)
     ^ "arg: "

analysis/src/Xform.ml

@@ -261,7 +261,7 @@ module AddBracesToFn = struct
         | _ -> false
       in
       (match e.pexp_desc with
-      | Pexp_fun (_, _, _, bodyExpr)
+      | Pexp_fun (_, _, _, bodyExpr, _)
         when Loc.hasPos ~pos bodyExpr.pexp_loc
              && isBracedExpr bodyExpr = false
              && isFunction bodyExpr = false ->
@@ -303,10 +303,10 @@ module AddTypeAnnotation = struct
     in
     let rec processFunction ~argNum (e : Parsetree.expression) =
       match e.pexp_desc with
-      | Pexp_fun (argLabel, _, pat, e)
+      | Pexp_fun (argLabel, _, pat, e, _)
       | Pexp_construct
           ( {txt = Lident "Function$"},
-            Some {pexp_desc = Pexp_fun (argLabel, _, pat, e)} ) ->
+            Some {pexp_desc = Pexp_fun (argLabel, _, pat, e, _)} ) ->
         let isUnlabeledOnlyArg =
           argNum = 1 && argLabel = Nolabel
           &&

compiler/frontend/ast_compatible.ml

@@ -63,11 +63,11 @@ let app3 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 arg3 : expression =
       Pexp_apply (fn, [(Nolabel, arg1); (Nolabel, arg2); (Nolabel, arg3)]);
   }
 
-let fun_ ?(loc = default_loc) ?(attrs = []) pat exp =
+let fun_ ?(loc = default_loc) ?(attrs = []) ~arity pat exp =
   {
     pexp_loc = loc;
     pexp_attributes = attrs;
-    pexp_desc = Pexp_fun (Nolabel, None, pat, exp);
+    pexp_desc = Pexp_fun (Nolabel, None, pat, exp, arity);
   }
 
 let const_exp_string ?(loc = default_loc) ?(attrs = []) ?delimiter (s : string)

compiler/frontend/ast_compatible.mli

@@ -72,7 +72,12 @@ val apply_labels :
 *)
 
 val fun_ :
-  ?loc:Location.t -> ?attrs:attrs -> pattern -> expression -> expression
+  ?loc:Location.t ->
+  ?attrs:attrs ->
+  arity:int option ->
+  pattern ->
+  expression ->
+  expression
 
 (* val opt_label : string -> Asttypes.arg_label *)
 

compiler/frontend/ast_derive_js_mapper.ml

@@ -128,7 +128,9 @@ let app1 = Ast_compatible.app1
 
 let app2 = Ast_compatible.app2
 
-let ( ->~ ) a b = Ast_compatible.arrow a b
+let ( ->~ ) a b =
+  Ast_uncurried.uncurried_type ~loc:Location.none ~arity:1
+    (Ast_compatible.arrow a b)
 
 let raise_when_not_found_ident =
   Longident.Ldot (Lident Primitive_modules.util, "raiseWhenNotFound")
@@ -167,9 +169,10 @@ let init () =
               in
               let to_js_body body =
                 Ast_comb.single_non_rec_value pat_to_js
-                  (Ast_compatible.fun_
-                     (Pat.constraint_ (Pat.var pat_param) core_type)
-                     body)
+                  (Ast_uncurried.uncurried_fun ~loc:Location.none ~arity:1
+                     (Ast_compatible.fun_ ~arity:None
+                        (Pat.constraint_ (Pat.var pat_param) core_type)
+                        body))
               in
               let ( +> ) a ty = Exp.constraint_ (erase_type a) ty in
               let ( +: ) a ty = erase_type (Exp.constraint_ a ty) in
@@ -211,12 +214,16 @@ let init () =
                 in
                 let from_js =
                   Ast_comb.single_non_rec_value pat_from_js
-                    (Ast_compatible.fun_ (Pat.var pat_param)
-                       (if create_type then
-                          Exp.let_ Nonrecursive
-                            [Vb.mk (Pat.var pat_param) (exp_param +: new_type)]
-                            (Exp.constraint_ obj_exp core_type)
-                        else Exp.constraint_ obj_exp core_type))
+                    (Ast_uncurried.uncurried_fun ~loc:Location.none ~arity:1
+                       (Ast_compatible.fun_ ~arity:(Some 1) (Pat.var pat_param)
+                          (if create_type then
+                             Exp.let_ Nonrecursive
+                               [
+                                 Vb.mk (Pat.var pat_param)
+                                   (exp_param +: new_type);
+                               ]
+                               (Exp.constraint_ obj_exp core_type)
+                           else Exp.constraint_ obj_exp core_type)))
                 in
                 let rest = [to_js; from_js] in
                 if create_type then erase_type_str :: new_type_str :: rest
@@ -253,12 +260,14 @@ let init () =
                            app2 unsafe_index_get_exp exp_map exp_param
                          else app1 erase_type_exp exp_param);
                       Ast_comb.single_non_rec_value pat_from_js
-                        (Ast_compatible.fun_ (Pat.var pat_param)
-                           (let result =
-                              app2 unsafe_index_get_exp rev_exp_map exp_param
-                            in
-                            if create_type then raise_when_not_found result
-                            else result));
+                        (Ast_uncurried.uncurried_fun ~loc:Location.none ~arity:1
+                           (Ast_compatible.fun_ ~arity:(Some 1)
+                              (Pat.var pat_param)
+                              (let result =
+                                 app2 unsafe_index_get_exp rev_exp_map exp_param
+                               in
+                               if create_type then raise_when_not_found result
+                               else result)));
                     ]
                   in
                   if create_type then new_type_str :: v else v
@@ -285,7 +294,8 @@ let init () =
               let pat_from_js = {Asttypes.loc; txt = from_js} in
               let to_js_type result =
                 Ast_comb.single_non_rec_val pat_to_js
-                  (Ast_compatible.arrow core_type result)
+                  (Ast_uncurried.uncurried_type ~loc:Location.none ~arity:1
+                     (Ast_compatible.arrow core_type result))
               in
               let new_type, new_tdcl =
                 U.new_type_of_type_declaration tdcl ("abs_" ^ name)

compiler/frontend/ast_derive_projector.ml

@@ -46,7 +46,7 @@ let init () =
                   ->
                     let txt = "param" in
                     Ast_comb.single_non_rec_value ?attrs:gentype_attrs pld_name
-                      (Ast_compatible.fun_
+                      (Ast_compatible.fun_ ~arity:(Some 1)
                          (Pat.constraint_ (Pat.var {txt; loc}) core_type)
                          (Exp.field
                             (Exp.ident {txt = Lident txt; loc})
@@ -108,7 +108,9 @@ let init () =
                              annotate_type
                          in
                          Ext_list.fold_right vars exp (fun var b ->
-                             Ast_compatible.fun_ (Pat.var {loc; txt = var}) b)
+                             Ast_compatible.fun_ ~arity:(Some 1)
+                               (Pat.var {loc; txt = var})
+                               b)
                          |> handle_uncurried_accessor_tranform ~loc ~arity))
               | Ptype_abstract | Ptype_open ->
                 Ast_derive_util.not_applicable tdcl.ptype_loc deriving_name;

compiler/frontend/ast_pat.ml

@@ -35,7 +35,7 @@ let is_unit_cont ~yes ~no (p : t) =
 let arity_of_fun (pat : Parsetree.pattern) (e : Parsetree.expression) =
   let rec aux (e : Parsetree.expression) =
     match e.pexp_desc with
-    | Pexp_fun (_, _, _, e) -> 1 + aux e (*FIXME error on optional*)
+    | Pexp_fun (_, _, _, e, _) -> 1 + aux e (*FIXME error on optional*)
     (* | Pexp_fun _
        -> Location.raise_errorf
            ~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) =
 
 let rec labels_of_fun (e : Parsetree.expression) =
   match e.pexp_desc with
-  | Pexp_fun (l, _, _, e) -> l :: labels_of_fun e
+  | Pexp_fun (l, _, _, e, _) -> l :: labels_of_fun e
   | _ -> []
 
 let rec is_single_variable_pattern_conservative (p : t) =

compiler/frontend/ast_uncurry_gen.ml

@@ -36,7 +36,7 @@ let to_method_callback loc (self : Bs_ast_mapper.mapper) label
     match Ast_attributes.process_attributes_rev body.pexp_attributes with
     | Nothing, attrs -> (
       match body.pexp_desc with
-      | Pexp_fun (arg_label, _, arg, body) ->
+      | Pexp_fun (arg_label, _, arg, body, _) ->
         Bs_syntaxerr.optional_err loc arg_label;
         aux ((arg_label, self.pat self arg, attrs) :: acc) body
       | _ -> (self.expr self body, acc))
@@ -45,7 +45,7 @@ let to_method_callback loc (self : Bs_ast_mapper.mapper) label
   let result, rev_extra_args = aux [(label, self_pat, [])] body in
   let body =
     Ext_list.fold_left rev_extra_args result (fun e (label, p, attrs) ->
-        Ast_helper.Exp.fun_ ~loc ~attrs label None p e)
+        Ast_helper.Exp.fun_ ~loc ~attrs ~arity:None label None p e)
   in
   let arity = List.length rev_extra_args in
   let arity_s = string_of_int arity in