New internal representation for uncurried types.

CHANGELOG.md

@@ -56,6 +56,7 @@ These are only breaking changes for unformatted code.
 - Treat `@meth` annotation as making the type uncurried for backwards compatibitly with some examples https://github.com/rescript-lang/rescript-compiler/pull/5845
 - Process `@set` annotation for field update as generating an uncurried function https://github.com/rescript-lang/rescript-compiler/pull/5846
 - Treat uncurried application of primitives like curried application, which produces better output https://github.com/rescript-lang/rescript-compiler/pull/5851
+- New internal representation for uncurried functions using built-in type `function$<fun_type, arity>` this avoids having to declare all the possible arities ahead of time https://github.com/rescript-lang/rescript-compiler/pull/5870
 
 # 10.1.1
 

Makefile

@@ -34,7 +34,7 @@ test-syntax-roundtrip: build
 	bash ./scripts/testok.sh
 
 test-gentype: build
-	make -C jscomp/gentype_tests/typescript-react-example test
+	make -C jscomp/gentype_tests/typescript-react-example clean test
 
 test-all: test test-gentype
 

jscomp/build_tests/cycle1/input.js

@@ -5,6 +5,8 @@ const fs = require('fs')
 const path = require('path')
 var rescript_exe = require("../../../scripts/bin_path").rescript_exe
 
+cp.execSync(`${rescript_exe} clean -with-deps`, { cwd: __dirname, });
+
 var output = cp.spawnSync(rescript_exe, { encoding: "utf8", shell: true });
 
 assert(/is dangling/.test(output.stdout));

jscomp/frontend/ast_core_type.ml

@@ -132,7 +132,7 @@ let get_uncurry_arity (ty : t) =
 
 let get_curry_arity (ty : t) =
   match ty.ptyp_desc with
-  | Ptyp_constr ({ txt = Ldot (Ldot (Lident "Js", "Fn"), _) }, [ t ]) ->
+  | Ptyp_constr ({ txt = Lident "function$" }, [ t; _ ]) ->
       get_uncurry_arity_aux t 0
   | _ -> get_uncurry_arity_aux ty 0
 

jscomp/frontend/ast_core_type_class_type.ml

@@ -71,9 +71,9 @@ let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) =
    ptyp_desc =
      ( Ptyp_arrow (label, args, body)
      | Ptyp_constr
-         (* Js.Fn.xx is re-wrapped around only in case Nothing below *)
-         ( { txt = Ldot (Ldot (Lident "Js", "Fn"), _) },
-           [ { ptyp_desc = Ptyp_arrow (label, args, body) } ] ) );
+         (* function$<...> is re-wrapped around only in case Nothing below *)
+         ( { txt = Lident "function$" },
+           [ { ptyp_desc = Ptyp_arrow (label, args, body) }; _ ] ) );
    (* let it go without regard label names,
       it will report error later when the label is not empty
    *)

jscomp/frontend/ast_external_process.ml

@@ -868,15 +868,19 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
     Location.raise_errorf ~loc
       "%@uncurry can not be applied to the whole definition";
   let prim_name_with_source = { name = prim_name; source = External } in
-  let type_annotation, build_uncurried_type = match type_annotation.ptyp_desc with
-    | Ptyp_constr ({txt = Ldot(Ldot(Lident "Js", "Fn"), arity_);_} as lid, [t]) ->
-      t, fun ~arity x ->
-          let arity = match arity with
-            | Some arity -> "arity" ^ string_of_int arity
-            | None -> arity_ in
-          let lid = {lid with txt = Longident.Ldot(Ldot(Lident "Js", "Fn"), arity)} in
-          {x with Parsetree.ptyp_desc = Ptyp_constr (lid, [x])}
-    | _ -> type_annotation, fun ~arity:_ x -> x in
+  let type_annotation, build_uncurried_type =
+    match type_annotation.ptyp_desc with
+    | Ptyp_constr (({ txt = Lident "function$"; _ } as lid), [ t; arity_ ]) ->
+        ( t,
+          fun ~arity x ->
+            let tArity =
+              match arity with
+              | Some arity -> Ast_uncurried.arityType ~loc arity
+              | None -> arity_
+            in
+            { x with Parsetree.ptyp_desc = Ptyp_constr (lid, [ x; tArity ]) } )
+    | _ -> (type_annotation, fun ~arity:_ x -> x)
+  in
   let result_type, arg_types_ty =
     (* Note this assumes external type is syntatic (no abstraction)*)
     Ast_core_type.list_of_arrow type_annotation

jscomp/frontend/ast_literal.ml

@@ -55,8 +55,6 @@ module Lid = struct
 
   let opaque : t = Ldot (js_internal, "opaque")
 
-  let js_fn : t = Ldot (Lident "Js", "Fn")
-
   let js_oo : t = Lident "Js_OO"
 
   let js_meth_callback : t = Ldot (js_oo, "Callback")

jscomp/frontend/ast_literal.mli

@@ -39,8 +39,6 @@ module Lid : sig
 
   val type_int : t
 
-  val js_fn : t
-
   val js_internal_full_apply : t
 
   val opaque : t

jscomp/frontend/ast_typ_uncurry.ml

@@ -23,9 +23,7 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
 type typ = Parsetree.core_type
-
 type 'a cxt = Ast_helper.loc -> Bs_ast_mapper.mapper -> 'a
-
 type uncurry_type_gen = (Asttypes.arg_label -> typ -> typ -> typ) cxt
 
 module Typ = Ast_helper.Typ
@@ -63,10 +61,5 @@ let to_uncurry_type loc (mapper : Bs_ast_mapper.mapper)
   let fn_type = Typ.arrow ~loc label first_arg typ in
   let arity = Ast_core_type.get_uncurry_arity fn_type in
   match arity with
-  | Some 0 ->
-      Typ.constr { txt = Ldot (Ast_literal.Lid.js_fn, "arity0"); loc } [ typ ]
-  | Some n ->
-      Typ.constr
-        { txt = Ldot (Ast_literal.Lid.js_fn, "arity" ^ string_of_int n); loc }
-        [ fn_type ]
+  | Some arity -> Ast_uncurried.uncurriedType ~loc ~arity fn_type
   | None -> assert false

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,7 +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;
-  let arity_s = string_of_int arity in
-  Pexp_record
-    ( [ ({ txt = Ldot (Ast_literal.Lid.js_fn, "I" ^ arity_s); loc }, body) ],
-      None )
+  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

@@ -115,17 +115,18 @@ let expr_mapper ~async_context ~in_function_def (self : mapper)
       | true, pexp_attributes ->
           Ast_bs_open.convertBsErrorFunction e.pexp_loc self pexp_attributes
             cases)
-  | Pexp_record
-      ( [
-          ( { txt = Ldot (Ldot (Lident "Js", "Fn"), _) },
-            ({ pexp_desc = Pexp_fun _; pexp_attributes } as inner_exp) );
-        ],
-        None )
-    when match Ast_attributes.process_attributes_rev pexp_attributes with
+  | _
+    when Ast_uncurried.exprIsUncurriedFun e
+         &&
+         match
+           Ast_attributes.process_attributes_rev
+             (Ast_uncurried.exprExtractUncurriedFun e).pexp_attributes
+         with
          | Meth_callback _, _ -> true
          | _ -> false ->
       (* Treat @this (. x, y, z) => ... just like @this (x, y, z) => ... *)
-      self.expr self inner_exp
+      let fun_expr = Ast_uncurried.exprExtractUncurriedFun e in
+      self.expr self fun_expr
   | Pexp_fun (label, _, pat, body) -> (
       let async = Ast_attributes.has_async_payload e.pexp_attributes <> None in
       match Ast_attributes.process_attributes_rev e.pexp_attributes with
@@ -136,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/gentype/TranslateStructure.ml

@@ -14,15 +14,9 @@ let rec addAnnotationsToTypes_ ~config ~(expr : Typedtree.expression)
       in
       let aName = Ident.name param in
       { aName; aType } :: nextTypes1
-  | ( Texp_record
-        { fields = [| ({ lbl_name = "I" }, Overridden (_, exprRecord)) |] },
-      Tconstr (path, _, _),
-      _ )
-    when match path |> TranslateTypeExprFromTypes.pathToList |> List.rev with
-         | [ "Js"; "Fn"; _arity ] -> true
-         | _ -> false ->
-      (* let uncurried1: Js.Fn.arity1(_) = {I: x => x |> string_of_int} *)
-      addAnnotationsToTypes_ ~config ~expr:exprRecord argTypes
+  | ( Texp_construct ({txt = Lident "Function$"}, _, [funExpr]), _, _) ->
+      (* let uncurried1: function$<_, _> = Function$(x => x |> string_of_int, [`Has_arity1]) *)
+      addAnnotationsToTypes_ ~config ~expr:funExpr argTypes
   | ( Texp_apply ({ exp_desc = Texp_ident (path, _, _) }, [ (_, Some expr1) ]),
       _,
       _ ) -> (

jscomp/gentype/TranslateTypeExprFromTypes.ml

@@ -205,134 +205,14 @@ let translateConstr ~config ~paramsTranslation ~(path : Path.t) ~typeEnv =
       { paramTranslation with type_ = Nullable paramTranslation.type_ }
   | ([ "Js"; "Promise"; "t" ] | ["promise"]), [ paramTranslation ] ->
       { paramTranslation with type_ = Promise paramTranslation.type_ }
-  | ( [ "Js"; "Internal"; "fn" ],
-      [ { dependencies = argsDependencies; type_ = Tuple ts }; ret ] ) ->
-      {
-        dependencies = argsDependencies @ ret.dependencies;
-        type_ =
-          Function
-            {
-              argTypes =
-                ts |> List.map (fun type_ -> { aName = ""; aType = type_ });
-              componentName = None;
-              retType = ret.type_;
-              typeVars = [];
-              uncurried = true;
-            };
-      }
-  | ( [ "Js"; "Internal"; "fn" ],
-      [
-        {
-          dependencies = argsDependencies;
-          type_ = Variant { noPayloads = [ { label = "Arity_0" } ] };
-        };
-        ret;
-      ] ) ->
-      {
-        dependencies = argsDependencies @ ret.dependencies;
-        type_ =
-          Function
-            {
-              argTypes = [];
-              componentName = None;
-              retType = ret.type_;
-              typeVars = [];
-              uncurried = true;
-            };
-      }
-  | [ "Js"; "Fn"; "arity0" ], [ ret ] ->
-      {
-        dependencies = ret.dependencies;
-        type_ =
-          Function
-            {
-              argTypes = [];
-              componentName = None;
-              retType = ret.type_;
-              typeVars = [];
-              uncurried = true;
-            };
-      }
-  | ( [
-        ("Js" | "Js_OO");
-        ("Fn" | "Meth");
-        ( "arity1" | "arity2" | "arity3" | "arity4" | "arity5" | "arity6"
-        | "arity7" | "arity8" | "arity9" | "arity10" | "arity11" | "arity12"
-        | "arity13" | "arity14" | "arity15" | "arity16" | "arity17" | "arity18"
-        | "arity19" | "arity20" | "arity21" | "arity22" );
-      ],
-      [ arg ] ) ->
+  | ( [ "function$"], [ arg; _arity ] ) ->
       {
         dependencies = arg.dependencies;
         type_ =
           (match arg.type_ with
           | Function function_ -> Function { function_ with uncurried = true }
           | _ -> arg.type_);
       }
-  | ( [ "Js"; "Internal"; "fn" ],
-      [ { dependencies = argsDependencies; type_ = singleT }; ret ] ) ->
-      let argTypes =
-        (match singleT with
-        | Variant { payloads = [ { t = Tuple argTypes } ] } -> argTypes
-        | Variant { payloads = [ { t = type_ } ] } -> [ type_ ]
-        | _ -> [ singleT ])
-        |> List.map (fun type_ -> { aName = ""; aType = type_ })
-      in
-      {
-        dependencies = argsDependencies @ ret.dependencies;
-        type_ =
-          Function
-            {
-              argTypes;
-              componentName = None;
-              retType = ret.type_;
-              typeVars = [];
-              uncurried = true;
-            };
-      }
-  | ( ([ "Js"; "Internal"; "meth" ] | [ "Js_internalOO"; "meth" ]),
-      [
-        {
-          dependencies = argsDependencies;
-          type_ =
-            Variant
-              { payloads = [ { case = { label = "Arity_1" }; t = type_ } ] };
-        };
-        ret;
-      ] ) ->
-      {
-        dependencies = argsDependencies @ ret.dependencies;
-        type_ =
-          Function
-            {
-              argTypes = [ { aName = ""; aType = type_ } ];
-              componentName = None;
-              retType = ret.type_;
-              typeVars = [];
-              uncurried = true;
-            };
-      }
-  | ( ([ "Js"; "Internal"; "meth" ] | [ "Js_internalOO"; "meth" ]),
-      [
-        {
-          dependencies = argsDependencies;
-          type_ = Variant { payloads = [ { t = Tuple ts } ] };
-        };
-        ret;
-      ] ) ->
-      {
-        dependencies = argsDependencies @ ret.dependencies;
-        type_ =
-          Function
-            {
-              argTypes =
-                ts |> List.map (fun type_ -> { aName = ""; aType = type_ });
-              componentName = None;
-              retType = ret.type_;
-              typeVars = [];
-              uncurried = true;
-            };
-      }
   | _ -> defaultCase ()
 
 type processVariant = {