Remove the arity parameter of type function$.

Author: cristianoc

analysis/src/CompletionBackEnd.ml

@@ -1362,7 +1362,7 @@ let rec completeTypedValue ?(typeArgContext : typeArgContext option) ~rawOpens
       | Tlink t1
       | Tsubst t1
       | Tpoly (t1, [])
-      | Tconstr (Pident {name = "function$"}, [t1; _], _) ->
+      | Tconstr (Pident {name = "function$"}, [t1], _) ->
         fnReturnsTypeT t1
       | Tarrow _ -> (
         match TypeUtils.extractFunctionType ~env ~package:full.package t with

analysis/src/CompletionJsx.ml

@@ -238,7 +238,7 @@ let getJsxLabels ~componentPath ~findTypeOfValue ~package =
       | Tlink t1
       | Tsubst t1
       | Tpoly (t1, [])
-      | Tconstr (Pident {name = "function$"}, [t1; _], _) ->
+      | Tconstr (Pident {name = "function$"}, [t1], _) ->
         getLabels t1
       | Tconstr (p, [propsType], _) when Path.name p = "React.component" -> (
         let rec getPropsType (t : Types.type_expr) =

analysis/src/CreateInterface.ml

@@ -123,7 +123,7 @@ let printSignature ~extractor ~signature =
       Ctype.newconstr (Pdot (Pident (Ident.create "React"), "element", 0)) []
     in
     match typ.desc with
-    | Tconstr (Pident {name = "function$"}, [typ; _], _) -> getComponentType typ
+    | Tconstr (Pident {name = "function$"}, [typ], _) -> getComponentType typ
     | Tarrow
         (_, {desc = Tconstr (Path.Pident propsId, typeArgs, _)}, retType, _, _)
       when Ident.name propsId = "props" ->

analysis/src/SignatureHelp.ml

@@ -118,7 +118,7 @@ let extractParameters ~signature ~typeStrForParser ~labelPrefixLen =
                  ptyp_desc =
                    Ptyp_constr
                      ( {txt = Lident "function$"},
-                       [({ptyp_desc = Ptyp_arrow _} as expr); _] );
+                       [({ptyp_desc = Ptyp_arrow _} as expr)] );
                };
            };
      } );

analysis/src/TypeUtils.ml

@@ -36,7 +36,7 @@ let findTypeViaLoc ~full ~debug (loc : Location.t) =
 
 let rec pathFromTypeExpr (t : Types.type_expr) =
   match t.desc with
-  | Tconstr (Pident {name = "function$"}, [t; _], _) -> pathFromTypeExpr t
+  | Tconstr (Pident {name = "function$"}, [t], _) -> pathFromTypeExpr t
   | Tconstr (path, _typeArgs, _)
   | Tlink {desc = Tconstr (path, _typeArgs, _)}
   | Tsubst {desc = Tconstr (path, _typeArgs, _)}
@@ -243,7 +243,7 @@ let rec extractFunctionType ~env ~package typ =
     match t.desc with
     | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ~env acc t1
     | Tarrow (label, tArg, tRet, _, _) -> loop ~env ((label, tArg) :: acc) tRet
-    | Tconstr (Pident {name = "function$"}, [t; _], _) ->
+    | Tconstr (Pident {name = "function$"}, [t], _) ->
       extractFunctionType ~env ~package t
     | Tconstr (path, typeArgs, _) -> (
       match References.digConstructor ~env ~package path with
@@ -283,7 +283,7 @@ let rec extractFunctionType2 ?typeArgContext ~env ~package typ =
     | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ?typeArgContext ~env acc t1
     | Tarrow (label, tArg, tRet, _, _) ->
       loop ?typeArgContext ~env ((label, tArg) :: acc) tRet
-    | Tconstr (Pident {name = "function$"}, [t; _], _) ->
+    | Tconstr (Pident {name = "function$"}, [t], _) ->
       extractFunctionType2 ?typeArgContext ~env ~package t
     | Tconstr (path, typeArgs, _) -> (
       match References.digConstructor ~env ~package path with
@@ -334,7 +334,7 @@ let rec extractType ?(printOpeningDebug = true)
     Some (Tstring env, typeArgContext)
   | Tconstr (Path.Pident {name = "exn"}, [], _) ->
     Some (Texn env, typeArgContext)
-  | Tconstr (Pident {name = "function$"}, [t; _], _) -> (
+  | Tconstr (Pident {name = "function$"}, [t], _) -> (
     match extractFunctionType2 ?typeArgContext t ~env ~package with
     | args, tRet, typeArgContext when args <> [] ->
       Some
@@ -910,7 +910,7 @@ let getArgs ~env (t : Types.type_expr) ~full =
     | Tlink t1
     | Tsubst t1
     | Tpoly (t1, [])
-    | Tconstr (Pident {name = "function$"}, [t1; _], _) ->
+    | Tconstr (Pident {name = "function$"}, [t1], _) ->
       getArgsLoop ~full ~env ~currentArgumentPosition t1
     | Tarrow (Labelled l, tArg, tRet, _, _) ->
       (SharedTypes.Completable.Labelled l, tArg)

compiler/frontend/ast_core_type_class_type.ml

@@ -73,7 +73,7 @@ let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) =
      | Ptyp_constr
          (* function$<...> is re-wrapped around only in case Nothing below *)
          ( {txt = Lident "function$"},
-           [{ptyp_desc = Ptyp_arrow (label, args, body, _)}; _] ) );
+           [{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
    *)

compiler/frontend/ast_external_process.ml

@@ -935,21 +935,16 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
   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 = Lident "function$"; _} as lid), [t; arity_]) ->
+    | Ptyp_constr (({txt = Lident "function$"; _} as lid), [t]) ->
       ( t,
         fun ~arity (x : Parsetree.core_type) ->
-          let t_arity =
-            match arity with
-            | Some arity -> Ast_uncurried.arity_type ~loc arity
-            | None -> arity_
-          in
           let x =
             match x.ptyp_desc with
             | Ptyp_arrow (l, t1, t2, _) ->
               {x with ptyp_desc = Ptyp_arrow (l, t1, t2, arity)}
             | _ -> x
           in
-          {x with Parsetree.ptyp_desc = Ptyp_constr (lid, [x; t_arity])} )
+          {x with Parsetree.ptyp_desc = Ptyp_constr (lid, [x])} )
     | _ -> (type_annotation, fun ~arity:_ x -> x)
   in
   let result_type, arg_types_ty =

compiler/gentype/TranslateTypeExprFromTypes.ml

@@ -231,8 +231,7 @@ let translate_constr ~config ~params_translation ~(path : Path.t) ~type_env =
     {param_translation with type_ = Promise param_translation.type_}
   | (["Js"; "Dict"; "t"] | ["Dict"; "t"] | ["dict"]), [param_translation] ->
     {param_translation with type_ = Dict param_translation.type_}
-  | ["function$"], [arg; _arity] ->
-    {dependencies = arg.dependencies; type_ = arg.type_}
+  | ["function$"], [arg] -> {dependencies = arg.dependencies; type_ = arg.type_}
   | _ -> default_case ()
 
 type process_variant = {

compiler/ml/ast_mapper_from0.ml

@@ -123,7 +123,7 @@ module T = struct
         let fun_t =
           {fun_t with ptyp_desc = Ptyp_arrow (lbl, t1, t2, Some arity)}
         in
-        {typ0 with ptyp_desc = Ptyp_constr (lid, [fun_t; t_arity])}
+        {typ0 with ptyp_desc = Ptyp_constr (lid, [fun_t])}
       | _ -> typ0)
     | Ptyp_object (l, o) ->
       object_ ~loc ~attrs (List.map (object_field sub) l) o

compiler/ml/ast_mapper_to0.ml

@@ -101,6 +101,17 @@ module T = struct
     | Ptyp_arrow (lab, t1, t2, _) ->
       arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
     | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
+    | Ptyp_constr
+        ( ({txt = Lident "function$"} as lid),
+          [({ptyp_desc = Ptyp_arrow (_, _, _, Some arity)} as t_arg)] ) ->
+      let encode_arity_string arity = "Has_arity" ^ string_of_int arity in
+      let arity_type ~loc arity =
+        Ast_helper0.Typ.variant ~loc
+          [Rtag ({txt = encode_arity_string arity; loc}, [], true, [])]
+          Closed None
+      in
+      constr ~loc ~attrs (map_loc sub lid)
+        [sub.typ sub t_arg; arity_type ~loc:Location.none arity]
     | Ptyp_constr (lid, tl) ->
       constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
     | Ptyp_object (l, o) ->

compiler/ml/ast_uncurried.ml

@@ -1,21 +1,13 @@
 (* Uncurried AST *)
 
-let encode_arity_string arity = "Has_arity" ^ string_of_int arity
-
-let arity_type ~loc arity =
-  Ast_helper.Typ.variant ~loc
-    [Rtag ({txt = encode_arity_string arity; loc}, [], true, [])]
-    Closed None
-
 let uncurried_type ~loc ~arity (t_arg : Parsetree.core_type) =
   let t_arg =
     match t_arg.ptyp_desc with
     | Ptyp_arrow (l, t1, t2, _) ->
       {t_arg with ptyp_desc = Ptyp_arrow (l, t1, t2, Some arity)}
     | _ -> assert false
   in
-  let t_arity = arity_type ~loc arity in
-  Ast_helper.Typ.constr ~loc {txt = Lident "function$"; loc} [t_arg; t_arity]
+  Ast_helper.Typ.constr ~loc {txt = Lident "function$"; loc} [t_arg]
 
 let uncurried_fun ~arity fun_expr =
   let fun_expr =
@@ -38,40 +30,27 @@ let expr_extract_uncurried_fun (expr : Parsetree.expression) =
 
 let core_type_is_uncurried_fun (typ : Parsetree.core_type) =
   match typ.ptyp_desc with
-  | Ptyp_constr ({txt = Lident "function$"}, [{ptyp_desc = Ptyp_arrow _}; _]) ->
+  | Ptyp_constr ({txt = Lident "function$"}, [{ptyp_desc = Ptyp_arrow _}]) ->
     true
   | _ -> false
 
 let core_type_extract_uncurried_fun (typ : Parsetree.core_type) =
   match typ.ptyp_desc with
   | Ptyp_constr
       ( {txt = Lident "function$"},
-        [({ptyp_desc = Ptyp_arrow (_, _, _, Some arity)} as t_arg); _] ) ->
+        [({ptyp_desc = Ptyp_arrow (_, _, _, Some arity)} as t_arg)] ) ->
     (arity, t_arg)
   | _ -> assert false
 
 let type_is_uncurried_fun = Ast_uncurried_utils.type_is_uncurried_fun
 
 let type_extract_uncurried_fun (typ : Types.type_expr) =
   match typ.desc with
-  | Tconstr (Pident {name = "function$"}, [t_arg; _], _) -> t_arg
+  | Tconstr (Pident {name = "function$"}, [t_arg], _) -> t_arg
   | _ -> assert false
 
 (* Typed AST *)
 
-let arity_to_type arity =
-  let arity_s = encode_arity_string arity in
-  Ctype.newty
-    (Tvariant
-       {
-         row_fields = [(arity_s, Rpresent None)];
-         row_more = Ctype.newty Tnil;
-         row_bound = ();
-         row_closed = true;
-         row_fixed = false;
-         row_name = None;
-       })
-
 let tarrow_to_arity (t_arity : Types.type_expr) =
   match (Ctype.repr t_arity).desc with
   | Tarrow (_, _, _, _, Some arity) -> arity
@@ -86,7 +65,6 @@ let tarrow_to_arity_opt (t_arity : Types.type_expr) =
   | _ -> None
 
 let make_uncurried_type ~env ~arity (t : Types.type_expr) =
-  let typ_arity = arity_to_type arity in
   let lid : Longident.t = Lident "function$" in
   let path = Env.lookup_type lid env in
   let t =
@@ -97,15 +75,14 @@ let make_uncurried_type ~env ~arity (t : Types.type_expr) =
     | Tvar _ -> t
     | _ -> assert false
   in
-  Ctype.newconstr path [t; typ_arity]
+  Ctype.newconstr path [t]
 
 let uncurried_type_get_arity ~env typ =
   match (Ctype.expand_head env typ).desc with
-  | Tconstr (Pident {name = "function$"}, [t; _arity], _) -> tarrow_to_arity t
+  | Tconstr (Pident {name = "function$"}, [t], _) -> tarrow_to_arity t
   | _ -> assert false
 
 let uncurried_type_get_arity_opt ~env typ =
   match (Ctype.expand_head env typ).desc with
-  | Tconstr (Pident {name = "function$"}, [t; _arity], _) ->
-    Some (tarrow_to_arity t)
+  | Tconstr (Pident {name = "function$"}, [t], _) -> Some (tarrow_to_arity t)
   | _ -> None

compiler/ml/ast_uncurried_utils.ml

@@ -1,4 +1,4 @@
 let type_is_uncurried_fun (typ : Types.type_expr) =
   match typ.desc with
-  | Tconstr (Pident {name = "function$"}, [{desc = Tarrow _}; _], _) -> true
+  | Tconstr (Pident {name = "function$"}, [{desc = Tarrow _}], _) -> true
   | _ -> false

compiler/ml/ctype.ml

@@ -2299,7 +2299,7 @@ and unify3 env t1 t1' t2 t2' =
   | Tfield _, Tfield _ ->
     (* special case for GADTs *)
     unify_fields env t1' t2'
-  | Tconstr (Pident {name = "function$"}, [t_fun; _], _), Tarrow _ ->
+  | Tconstr (Pident {name = "function$"}, [t_fun], _), Tarrow _ ->
     (* subtype: an uncurried function is cast to a curried one *)
     unify2 env t_fun t2
   | _ -> (

compiler/ml/predef.ml

@@ -319,13 +319,13 @@ let common_initial_env add_type add_extension empty_env =
             Record_regular );
     }
   and decl_uncurried =
-    let tvar1, tvar2 = (newgenvar (), newgenvar ()) in
+    let tvar1 = newgenvar () in
     {
       decl_abstr with
-      type_params = [tvar1; tvar2];
-      type_arity = 2;
+      type_params = [tvar1];
+      type_arity = 1;
       type_kind = Type_variant [cstr ident_ctor_uncurried [tvar1]];
-      type_variance = [Variance.covariant; Variance.covariant];
+      type_variance = [Variance.covariant];
       type_unboxed = Types.unboxed_true_default_false;
     }
   and decl_unknown =

compiler/ml/typecore.ml

@@ -3530,7 +3530,7 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) :
   let has_uncurried_type funct =
     let t = funct.exp_type in
     match (expand_head env t).desc with
-    | Tconstr (Pident {name = "function$"}, [t; _t_arity], _) ->
+    | Tconstr (Pident {name = "function$"}, [t], _) ->
       let arity =
         match Ast_uncurried.tarrow_to_arity_opt t with
         | Some arity -> arity
@@ -4333,10 +4333,7 @@ let report_error env ppf = function
       "This function is a curried function where an uncurried function is \
        expected"
   | Expr_type_clash
-      ( ( _,
-          {
-            desc = Tconstr (Pident {name = "function$"}, [{desc = Tvar _}; _], _);
-          } )
+      ( (_, {desc = Tconstr (Pident {name = "function$"}, [{desc = Tvar _}], _)})
         :: (_, {desc = Tarrow _})
         :: _,
         _ ) ->
@@ -4349,15 +4346,15 @@ let report_error env ppf = function
             desc =
               Tconstr
                 ( Pident {name = "function$"},
-                  [{desc = Tarrow (_, _, _, _, Some arity_a)}; _],
+                  [{desc = Tarrow (_, _, _, _, Some arity_a)}],
                   _ );
           } )
         :: ( _,
              {
                desc =
                  Tconstr
                    ( Pident {name = "function$"},
-                     [{desc = Tarrow (_, _, _, _, Some arity_b)}; _],
+                     [{desc = Tarrow (_, _, _, _, Some arity_b)}],
                      _ );
              } )
         :: _,

compiler/syntax/src/res_comments_table.ml

@@ -1865,7 +1865,7 @@ and walk_core_type typ t comments =
   | Ptyp_variant (row_fields, _, _) ->
     walk_list (row_fields |> List.map (fun rf -> RowField rf)) t comments
   | Ptyp_constr
-      ({txt = Lident "function$"}, [({ptyp_desc = Ptyp_arrow _} as desc); _]) ->
+      ({txt = Lident "function$"}, [({ptyp_desc = Ptyp_arrow _} as desc)]) ->
     walk_core_type desc t comments
   | Ptyp_constr (longident, typexprs) ->
     let before_longident, _afterLongident =

compiler/syntax/src/res_outcome_printer.ml

@@ -156,11 +156,10 @@ let rec print_out_type_doc (out_type : Outcometree.out_type) =
         [(Otyp_arrow _ as arrow_type)] ) ->
     (* Compatibility with compiler up to v10.x *)
     print_out_arrow_type arrow_type
-  | Otyp_constr (Oide_ident "function$", [(Otyp_arrow _ as arrow_type); _arity])
-    ->
-    (* function$<(int, int) => int, [#2]> -> (. int, int) => int *)
+  | Otyp_constr (Oide_ident "function$", [(Otyp_arrow _ as arrow_type)]) ->
+    (* function$<(int, int) => int> -> (int, int) => int *)
     print_out_arrow_type arrow_type
-  | Otyp_constr (Oide_ident "function$", [Otyp_var _; _arity]) ->
+  | Otyp_constr (Oide_ident "function$", [Otyp_var _]) ->
     (* function$<'a, arity> -> _ => _ *)
     print_out_type_doc (Otyp_stuff "_ => _")
   | Otyp_constr (out_ident, []) ->
@@ -299,7 +298,7 @@ and print_out_arrow_type typ =
       | [
        ( _,
          ( Otyp_tuple _ | Otyp_arrow _
-         | Otyp_constr (Oide_ident "function$", [Otyp_arrow _; _]) ) );
+         | Otyp_constr (Oide_ident "function$", [Otyp_arrow _]) ) );
       ] ->
         true
       (* single argument should not be wrapped *)

tests/syntax_tests/data/parsing/errors/other/expected/labelledParameters.res.txt

@@ -34,4 +34,4 @@
 let f [arity:3]x ?(y= 2)  z = (x + y) + z
 let g [arity:3]~x:((x)[@res.namedArgLoc ])  ?y:(((y)[@res.namedArgLoc ])= 2) 
   ~z:((z)[@res.namedArgLoc ])  = (x + y) + z
-type nonrec f = (x:int -> y:int -> int (a:2), [ `Has_arity2 ]) function$
+type nonrec f = (x:int -> y:int -> int (a:2)) function$

tests/syntax_tests/data/parsing/errors/other/expected/regionMissingComma.res.txt

@@ -24,8 +24,8 @@
 
 external make :
   (?style:((ReactDOMRe.Style.t)[@res.namedArgLoc ]) ->
-     ?image:((bool)[@res.namedArgLoc ]) -> React.element (a:2),
-    [ `Has_arity2 ]) function$ = "ModalContent"
+     ?image:((bool)[@res.namedArgLoc ]) -> React.element (a:2))
+    function$ = "ModalContent"
 type nonrec 'extraInfo student =
   {
   name: string ;

tests/syntax_tests/data/parsing/errors/structure/expected/external.res.txt

@@ -9,5 +9,4 @@
   An external requires the name of the JS value you're referring to, like "setTimeout".
 
 external setTimeout :
-  ((unit -> unit (a:1), [ `Has_arity1 ]) function$ -> int -> float (a:2),
-    [ `Has_arity2 ]) function$
+  ((unit -> unit (a:1)) function$ -> int -> float (a:2)) function$

tests/syntax_tests/data/parsing/errors/typeDef/expected/inlineRecord.res.txt

@@ -46,6 +46,6 @@ type nonrec user =
 let make
   [arity:1](props :
              <
-               handleClick: (Click.t -> unit (a:1), [ `Has_arity1 ])
-                              function$  ;value: string   > )
+               handleClick: (Click.t -> unit (a:1)) function$  ;value: 
+                                                                  string   > )
   = render props

tests/syntax_tests/data/parsing/errors/typeDef/expected/namedParameters.res.txt

@@ -7,4 +7,4 @@
 
   A labeled parameter starts with a `~`. Did you mean: `~stroke`?
 
-type nonrec draw = (stroke:pencil -> unit (a:1), [ `Has_arity1 ]) function$
+type nonrec draw = (stroke:pencil -> unit (a:1)) function$