Represent the arity of uncurried function definitions directly in the AST.

Author: cristianoc

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

@@ -167,7 +167,7 @@ let init () =
               in
               let to_js_body body =
                 Ast_comb.single_non_rec_value pat_to_js
-                  (Ast_compatible.fun_
+                  (Ast_compatible.fun_ ~arity:None
                      (Pat.constraint_ (Pat.var pat_param) core_type)
                      body)
               in
@@ -211,7 +211,7 @@ let init () =
                 in
                 let from_js =
                   Ast_comb.single_non_rec_value pat_from_js
-                    (Ast_compatible.fun_ (Pat.var pat_param)
+                    (Ast_compatible.fun_ ~arity:None (Pat.var pat_param)
                        (if create_type then
                           Exp.let_ Nonrecursive
                             [Vb.mk (Pat.var pat_param) (exp_param +: new_type)]
@@ -253,7 +253,7 @@ 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)
+                        (Ast_compatible.fun_ ~arity:None (Pat.var pat_param)
                            (let result =
                               app2 unsafe_index_get_exp rev_exp_map exp_param
                             in

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:None
                          (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:None
+                               (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

compiler/frontend/bs_ast_mapper.ml

@@ -315,8 +315,8 @@ module E = struct
            sub vbs)
         (sub.expr sub e)
     (* #end *)
-    | Pexp_fun (lab, def, p, e) ->
-      fun_ ~loc ~attrs lab
+    | Pexp_fun (lab, def, p, e, arity) ->
+      fun_ ~loc ~attrs ~arity lab
         (map_opt (sub.expr sub) def)
         (sub.pat sub p) (sub.expr sub e)
     | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)