Change representation: pass arity in an attribute.

Using a constraint to determine the arity in a function definition is problematic as the constraint limits type propagation during inference.
Instead, pass the arity via an attribute @res.arity on the Js.Uncurried variant.
And specialize the type checker to handle that arity and use type unification to propagate the arity.

Author: cristianoc

jscomp/frontend/ast_uncurry_gen.ml

@@ -67,8 +67,9 @@ let to_method_callback loc (self : Bs_ast_mapper.mapper) label
                [ Typ.any ~loc () ]) );
       ] )
 
-let to_uncurry_fn loc (self : Bs_ast_mapper.mapper) (label : Asttypes.arg_label)
-    pat body async : Parsetree.expression_desc =
+let to_uncurry_fn (e : Parsetree.expression) (self : Bs_ast_mapper.mapper)
+    (label : Asttypes.arg_label) pat body async : Parsetree.expression =
+  let loc = e.pexp_loc in
   Bs_syntaxerr.optional_err loc label;
   let rec aux acc (body : Parsetree.expression) =
     match Ast_attributes.process_attributes_rev body.pexp_attributes with
@@ -97,4 +98,9 @@ let to_uncurry_fn loc (self : Bs_ast_mapper.mapper) (label : Asttypes.arg_label)
     | _ -> len
   in
   Bs_syntaxerr.err_large_arity loc arity;
-  (Ast_uncurried.uncurriedFun ~loc ~arity body).pexp_desc
+  let fun_exp = Ast_uncurried.uncurriedFun ~loc ~arity body in
+  {
+    e with
+    pexp_desc = fun_exp.pexp_desc;
+    pexp_attributes = fun_exp.pexp_attributes @ e.pexp_attributes;
+  }

jscomp/frontend/ast_uncurry_gen.mli

@@ -23,13 +23,13 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
 val to_uncurry_fn :
-  Location.t ->
+  Parsetree.expression ->
   Bs_ast_mapper.mapper ->
   Asttypes.arg_label ->
   Parsetree.pattern ->
   Parsetree.expression ->
   bool -> (* async *)
-  Parsetree.expression_desc
+  Parsetree.expression
 (** 
     [function] can only take one argument, that is the reason we did not adopt it
     syntax:

jscomp/frontend/bs_builtin_ppx.ml

@@ -137,12 +137,8 @@ let expr_mapper ~async_context ~in_function_def (self : mapper)
           Ast_async.make_function_async ~async (default_expr_mapper self e)
       | Uncurry _, pexp_attributes ->
           async_context := async;
-          {
-            e with
-            pexp_desc =
-              Ast_uncurry_gen.to_uncurry_fn e.pexp_loc self label pat body async;
-            pexp_attributes;
-          }
+          Ast_uncurry_gen.to_uncurry_fn { e with pexp_attributes } self label
+            pat body async
       | Method _, _ ->
           Location.raise_errorf ~loc:e.pexp_loc
             "%@meth is not supported in function expression"

jscomp/ml/ast_uncurried.ml

@@ -21,21 +21,39 @@ let uncurriedType ~loc ~arity tArg =
       }
       [ tArg ]
 
+let arity_to_attributes arity =
+  [
+    ( Location.mknoloc "res.arity",
+      Parsetree.PStr
+        [
+          Ast_helper.Str.eval
+            (Ast_helper.Exp.constant
+               (Pconst_integer (string_of_int arity, None)));
+        ] );
+  ]
+
+let rec attributes_to_arity (attrs : Parsetree.attributes) =
+  match attrs with
+  | ( { txt = "res.arity" },
+      PStr
+        [
+          {
+            pstr_desc =
+              Pstr_eval
+                ({ pexp_desc = Pexp_constant (Pconst_integer (arity, _)) }, _);
+          };
+        ] )
+    :: _ ->
+      int_of_string arity
+  | _ :: rest -> attributes_to_arity rest
+  | _ -> assert false
+
 let uncurriedFun ~loc ~arity funExpr =
   if new_representation arity then
-    let tArity = arityType ~loc arity in
-    let tAny = Ast_helper.Typ.any ~loc () in
-    let tUncurried =
-      Ast_helper.Typ.constr ~loc
-        { txt = Ldot (Lident "Js", "uncurried"); loc }
-        [ tAny; tArity ]
-    in
-    let expr =
-      Ast_helper.Exp.construct ~loc
-        { txt = Ldot (Lident "Js", "Uncurried"); loc }
-        (Some funExpr)
-    in
-    Ast_helper.Exp.constraint_ ~loc expr tUncurried
+    Ast_helper.Exp.construct ~loc
+      ~attrs:(arity_to_attributes arity)
+      { txt = Ldot (Lident "Js", "Uncurried"); loc }
+      (Some funExpr)
   else
     Ast_helper.Exp.record ~loc
       [
@@ -52,26 +70,14 @@ let exprIsUncurriedFun (expr : Parsetree.expression) =
   | Pexp_record ([ ({ txt = Ldot (Ldot (Lident "Js", "Fn"), _) }, _e) ], None)
     ->
       true
-  | Pexp_constraint
-      ( {
-          pexp_desc =
-            Pexp_construct ({ txt = Ldot (Lident "Js", "Uncurried") }, Some _);
-        },
-        _ ) ->
-      true
+  | Pexp_construct ({ txt = Ldot (Lident "Js", "Uncurried") }, Some _) -> true
   | _ -> false
 
 let exprExtractUncurriedFun (expr : Parsetree.expression) =
   match expr.pexp_desc with
   | Pexp_record ([ ({ txt = Ldot (Ldot (Lident "Js", "Fn"), _) }, e) ], None) ->
       e
-  | Pexp_constraint
-      ( {
-          pexp_desc =
-            Pexp_construct ({ txt = Ldot (Lident "Js", "Uncurried") }, Some e);
-        },
-        _ ) ->
-      e
+  | Pexp_construct ({ txt = Ldot (Lident "Js", "Uncurried") }, Some e) -> e
   | _ -> assert false
 
 (* Typed AST *)
@@ -92,6 +98,9 @@ let arity_to_type arity =
 let type_to_arity (tArity : Types.type_expr) =
   match tArity.desc with
   | Tvariant { row_fields = [ (label, _) ] } -> int_of_string label
+  | Tconstr _ -> assert false
+  | Tvar _ -> assert false
+  | Tsubst _ -> assert false
   | _ -> assert false
 
 let mk_js_fn ~env ~arity t =

jscomp/ml/typecore.ml

@@ -2104,6 +2104,12 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
         exp_attributes = sexp.pexp_attributes;
         exp_env = env }
   | Pexp_construct(lid, sarg) ->
+      (match lid.txt with
+      | Ldot (Lident "Js", "Uncurried") ->
+        let arity = Ast_uncurried.attributes_to_arity sexp.pexp_attributes in
+        let uncurried_typ = Ast_uncurried.mk_js_fn ~env ~arity (newvar()) in
+        unify_exp_types loc env uncurried_typ ty_expected
+      | _ -> ());
       type_construct env loc lid sarg ty_expected sexp.pexp_attributes
   | Pexp_variant(l, sarg) ->
       (* Keep sharing *)