Prepare tp remove function$

analysis/src/CompletionBackEnd.ml

@@ -1358,12 +1358,8 @@ let rec completeTypedValue ?(typeArgContext : typeArgContext option) ~rawOpens
     in
     (* Find all functions in the module that returns type t *)
     let rec fnReturnsTypeT t =
-      match t.Types.desc with
-      | Tlink t1
-      | Tsubst t1
-      | Tpoly (t1, [])
-      | Tconstr (Pident {name = "function$"}, [t1], _) ->
-        fnReturnsTypeT t1
+      match (Ast_uncurried.remove_function_dollar t).desc with
+      | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> fnReturnsTypeT t1
       | Tarrow _ -> (
         match TypeUtils.extractFunctionType ~env ~package:full.package t with
         | ( (Nolabel, {desc = Tconstr (Path.Pident {name = "t"}, _, _)}) :: _,

analysis/src/CompletionJsx.ml

@@ -234,12 +234,8 @@ let getJsxLabels ~componentPath ~findTypeOfValue ~package =
       | _ -> []
     in
     let rec getLabels (t : Types.type_expr) =
-      match t.desc with
-      | Tlink t1
-      | Tsubst t1
-      | Tpoly (t1, [])
-      | Tconstr (Pident {name = "function$"}, [t1], _) ->
-        getLabels t1
+      match (Ast_uncurried.remove_function_dollar t).desc with
+      | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> getLabels t1
       | Tconstr (p, [propsType], _) when Path.name p = "React.component" -> (
         let rec getPropsType (t : Types.type_expr) =
           match t.desc with

analysis/src/CreateInterface.ml

@@ -118,12 +118,11 @@ let printSignature ~extractor ~signature =
 
   let buf = Buffer.create 10 in
 
-  let rec getComponentType (typ : Types.type_expr) =
+  let getComponentType (typ : Types.type_expr) =
     let reactElement =
       Ctype.newconstr (Pdot (Pident (Ident.create "React"), "element", 0)) []
     in
-    match typ.desc with
-    | Tconstr (Pident {name = "function$"}, [typ], _) -> getComponentType typ
+    match (Ast_uncurried.remove_function_dollar typ).desc with
     | Tarrow
         (_, {desc = Tconstr (Path.Pident propsId, typeArgs, _)}, retType, _, _)
       when Ident.name propsId = "props" ->

analysis/src/SignatureHelp.ml

@@ -104,25 +104,13 @@ let findFunctionType ~currentFile ~debug ~path ~pos =
 (* Extracts all parameters from a parsed function signature *)
 let extractParameters ~signature ~typeStrForParser ~labelPrefixLen =
   match signature with
-  | [
-   ( {
-       Parsetree.psig_desc =
-         Psig_value {pval_type = {ptyp_desc = Ptyp_arrow _} as expr};
-     }
-   | {
-       psig_desc =
-         Psig_value
-           {
-             pval_type =
-               {
-                 ptyp_desc =
-                   Ptyp_constr
-                     ( {txt = Lident "function$"},
-                       [({ptyp_desc = Ptyp_arrow _} as expr)] );
-               };
-           };
-     } );
-  ] ->
+  | [{Parsetree.psig_desc = Psig_value {pval_type = expr}}]
+    when match
+           (Ast_uncurried.core_type_remove_function_dollar expr).ptyp_desc
+         with
+         | Ptyp_arrow _ -> true
+         | _ -> false ->
+    let expr = Ast_uncurried.core_type_remove_function_dollar expr in
     let rec extractParams expr params =
       match expr with
       | {

analysis/src/TypeUtils.ml

@@ -34,9 +34,8 @@ let findTypeViaLoc ~full ~debug (loc : Location.t) =
   | Some {locType = Typed (_, typExpr, _)} -> Some typExpr
   | _ -> None
 
-let rec pathFromTypeExpr (t : Types.type_expr) =
-  match t.desc with
-  | Tconstr (Pident {name = "function$"}, [t], _) -> pathFromTypeExpr t
+let pathFromTypeExpr (t : Types.type_expr) =
+  match (Ast_uncurried.remove_function_dollar t).desc with
   | Tconstr (path, _typeArgs, _)
   | Tlink {desc = Tconstr (path, _typeArgs, _)}
   | Tsubst {desc = Tconstr (path, _typeArgs, _)}
@@ -238,13 +237,11 @@ let rec extractObjectType ~env ~package (t : Types.type_expr) =
     | _ -> None)
   | _ -> None
 
-let rec extractFunctionType ~env ~package typ =
+let extractFunctionType ~env ~package typ =
   let rec loop ~env acc (t : Types.type_expr) =
-    match t.desc with
+    match (Ast_uncurried.remove_function_dollar 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], _) ->
-      extractFunctionType ~env ~package t
     | Tconstr (path, typeArgs, _) -> (
       match References.digConstructor ~env ~package path with
       | Some
@@ -277,14 +274,12 @@ let maybeSetTypeArgCtx ?typeArgContextFromTypeManifest ~typeParams ~typeArgs env
     typeArgContext
 
 (* TODO(env-stuff) Maybe this could be removed entirely if we can guarantee that we don't have to look up functions from in here. *)
-let rec extractFunctionType2 ?typeArgContext ~env ~package typ =
+let extractFunctionType2 ?typeArgContext ~env ~package typ =
   let rec loop ?typeArgContext ~env acc (t : Types.type_expr) =
-    match t.desc with
+    match (Ast_uncurried.remove_function_dollar t).desc with
     | 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], _) ->
-      extractFunctionType2 ?typeArgContext ~env ~package t
     | Tconstr (path, typeArgs, _) -> (
       match References.digConstructor ~env ~package path with
       | Some
@@ -317,7 +312,7 @@ let rec extractType ?(printOpeningDebug = true)
       Printf.printf "[extract_type]--> %s"
         (debugLogTypeArgContext typeArgContext));
   let instantiateType = instantiateType2 in
-  match t.desc with
+  match (Ast_uncurried.remove_function_dollar t).desc with
   | Tlink t1 | Tsubst t1 | Tpoly (t1, []) ->
     extractType ?typeArgContext ~printOpeningDebug:false ~env ~package t1
   | Tconstr (Path.Pident {name = "option"}, [payloadTypeExpr], _) ->
@@ -334,13 +329,6 @@ let rec extractType ?(printOpeningDebug = true)
     Some (Tstring env, typeArgContext)
   | Tconstr (Path.Pident {name = "exn"}, [], _) ->
     Some (Texn env, typeArgContext)
-  | Tconstr (Pident {name = "function$"}, [t], _) -> (
-    match extractFunctionType2 ?typeArgContext t ~env ~package with
-    | args, tRet, typeArgContext when args <> [] ->
-      Some
-        ( Tfunction {env; args; typ = t; uncurried = true; returnType = tRet},
-          typeArgContext )
-    | _args, _tRet, _typeArgContext -> None)
   | Tarrow _ -> (
     match extractFunctionType2 ?typeArgContext t ~env ~package with
     | args, tRet, typeArgContext when args <> [] ->
@@ -906,11 +894,8 @@ let rec resolveNestedPatternPath (typ : innerType) ~env ~full ~nested =
 let getArgs ~env (t : Types.type_expr) ~full =
   let rec getArgsLoop ~env (t : Types.type_expr) ~full ~currentArgumentPosition
       =
-    match t.desc with
-    | Tlink t1
-    | Tsubst t1
-    | Tpoly (t1, [])
-    | Tconstr (Pident {name = "function$"}, [t1], _) ->
+    match (Ast_uncurried.remove_function_dollar t).desc with
+    | Tlink t1 | Tsubst t1 | Tpoly (t1, []) ->
       getArgsLoop ~full ~env ~currentArgumentPosition t1
     | Tarrow (Labelled l, tArg, tRet, _, _) ->
       (SharedTypes.Completable.Labelled l, tArg)

compiler/frontend/ast_core_type.ml

@@ -124,10 +124,10 @@ let get_uncurry_arity (ty : t) =
   | _ -> None
 
 let get_curry_arity (ty : t) =
-  if Ast_uncurried.core_type_is_uncurried_fun ty then
-    let arity, _ = Ast_uncurried.core_type_extract_uncurried_fun ty in
-    arity
-  else get_uncurry_arity_aux ty 0
+  match Ast_uncurried.core_type_remove_function_dollar ty with
+  | {ptyp_desc = Ptyp_arrow (_, _, _, Some arity)} -> arity
+  | _ -> get_uncurry_arity_aux ty 0
+
 let is_arity_one ty = get_curry_arity ty = 1
 
 type param_type = {
@@ -138,12 +138,20 @@ type param_type = {
 }
 
 let mk_fn_type (new_arg_types_ty : param_type list) (result : t) : t =
-  Ext_list.fold_right new_arg_types_ty result (fun {label; ty; attr; loc} acc ->
-      {
-        ptyp_desc = Ptyp_arrow (label, ty, acc, None);
-        ptyp_loc = loc;
-        ptyp_attributes = attr;
-      })
+  let t =
+    Ext_list.fold_right new_arg_types_ty result
+      (fun {label; ty; attr; loc} acc ->
+        {
+          ptyp_desc = Ptyp_arrow (label, ty, acc, None);
+          ptyp_loc = loc;
+          ptyp_attributes = attr;
+        })
+  in
+  match t.ptyp_desc with
+  | Ptyp_arrow (l, t1, t2, _arity) ->
+    let arity = List.length new_arg_types_ty in
+    {t with ptyp_desc = Ptyp_arrow (l, t1, t2, Some arity)}
+  | _ -> t
 
 let list_of_arrow (ty : t) : t * param_type list =
   let rec aux (ty : t) acc =

compiler/frontend/ast_core_type_class_type.ml

@@ -65,28 +65,20 @@ let default_typ_mapper = Bs_ast_mapper.default_mapper.typ
 *)
 
 let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) =
-  match ty with
-  | {
-   ptyp_attributes;
-   ptyp_desc =
-     ( Ptyp_arrow (label, args, body, _)
-     | Ptyp_constr
-         (* 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
-   *)
-   ptyp_loc = loc;
-  } -> (
-    match fst (Ast_attributes.process_attributes_rev ptyp_attributes) with
+  let loc = ty.ptyp_loc in
+  match (Ast_uncurried.core_type_remove_function_dollar ty).ptyp_desc with
+  | Ptyp_arrow (label, args, body, _)
+  (* let it go without regard label names,
+     it will report error later when the label is not empty
+  *) -> (
+    match fst (Ast_attributes.process_attributes_rev ty.ptyp_attributes) with
     | Meth_callback _ ->
       Ast_typ_uncurry.to_method_callback_type loc self label args body
     | Method _ ->
       (* Treat @meth as making the type uncurried, for backwards compatibility *)
       Ast_typ_uncurry.to_uncurry_type loc self label args body
     | Nothing -> Bs_ast_mapper.default_mapper.typ self ty)
-  | {ptyp_desc = Ptyp_object (methods, closed_flag); ptyp_loc = loc} ->
+  | Ptyp_object (methods, closed_flag) ->
     let ( +> ) attr (typ : Parsetree.core_type) =
       {typ with ptyp_attributes = attr :: typ.ptyp_attributes}
     in

compiler/frontend/ast_derive_abstract.ml

@@ -105,18 +105,25 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
           let is_optional = Ast_attributes.has_bs_optional pld_attributes in
 
           let maker, acc =
+            let arity =
+              if List.length labels = List.length label_declarations - 1 then
+                (* toplevel type *)
+                Some ((if has_optional_field then 2 else 1) + List.length labels)
+              else None
+            in
             if is_optional then
               let optional_type = Ast_core_type.lift_option_type pld_type in
-              ( Ast_compatible.opt_arrow ~loc:pld_loc ~arity:None label_name
-                  pld_type maker,
+              ( Ast_compatible.opt_arrow ~loc:pld_loc ~arity label_name pld_type
+                  maker,
                 Val.mk ~loc:pld_loc
                   (if light then pld_name
                    else {pld_name with txt = pld_name.txt ^ "Get"})
                   ~attrs:get_optional_attrs ~prim
-                  (Ast_compatible.arrow ~loc ~arity:None core_type optional_type)
+                  (Ast_compatible.arrow ~loc ~arity:(Some 1) core_type
+                     optional_type)
                 :: acc )
             else
-              ( Ast_compatible.label_arrow ~loc:pld_loc ~arity:None label_name
+              ( Ast_compatible.label_arrow ~loc:pld_loc ~arity label_name
                   pld_type maker,
                 Val.mk ~loc:pld_loc
                   (if light then pld_name
@@ -127,14 +134,14 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
                      External_ffi_types.ffi_bs_as_prims
                        [External_arg_spec.dummy] Return_identity
                        (Js_get {js_get_name = prim_as_name; js_get_scopes = []}))
-                  (Ast_compatible.arrow ~loc ~arity:None core_type pld_type)
+                  (Ast_compatible.arrow ~loc ~arity:(Some 1) core_type pld_type)
                 :: acc )
           in
           let is_current_field_mutable = pld_mutable = Mutable in
           let acc =
             if is_current_field_mutable then
               let setter_type =
-                Ast_compatible.arrow ~arity:None core_type
+                Ast_compatible.arrow ~arity:(Some 2) core_type
                   (Ast_compatible.arrow ~arity:None pld_type (* setter *)
                      (Ast_literal.type_unit ()))
               in

compiler/frontend/ast_derive_js_mapper.ml

@@ -67,7 +67,7 @@ let erase_type_str =
   Str.primitive
     (Val.mk ~prim:["%identity"]
        {loc = noloc; txt = erase_type_lit}
-       (Ast_compatible.arrow ~arity:None any any))
+       (Ast_compatible.arrow ~arity:(Some 1) any any))
 
 let unsafe_index = "_index"
 

compiler/frontend/ast_exp_handle_external.ml

@@ -43,7 +43,8 @@ let handle_external loc (x : string) : Parsetree.expression =
       str_exp with
       pexp_desc =
         Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
-          ~pval_type:(Typ.arrow ~arity:None Nolabel (Typ.any ()) (Typ.any ()))
+          ~pval_type:
+            (Typ.arrow ~arity:(Some 1) Nolabel (Typ.any ()) (Typ.any ()))
           [str_exp];
     }
   in
@@ -69,7 +70,8 @@ let handle_debugger loc (payload : Ast_payload.t) =
   | PStr [] ->
     Ast_external_mk.local_external_apply loc ~pval_prim:["%debugger"]
       ~pval_type:
-        (Typ.arrow ~arity:None Nolabel (Typ.any ()) (Ast_literal.type_unit ()))
+        (Typ.arrow ~arity:(Some 1) Nolabel (Typ.any ())
+           (Ast_literal.type_unit ()))
       [Ast_literal.val_unit ~loc ()]
   | _ ->
     Location.raise_errorf ~loc "%%debugger extension doesn't accept arguments"
@@ -93,7 +95,8 @@ let handle_raw ~kind loc payload =
       exp with
       pexp_desc =
         Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
-          ~pval_type:(Typ.arrow ~arity:None Nolabel (Typ.any ()) (Typ.any ()))
+          ~pval_type:
+            (Typ.arrow ~arity:(Some 1) Nolabel (Typ.any ()) (Typ.any ()))
           [exp];
       pexp_attributes =
         (match !is_function with
@@ -142,7 +145,8 @@ let handle_ffi ~loc ~payload =
         exp with
         pexp_desc =
           Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
-            ~pval_type:(Typ.arrow ~arity:None Nolabel (Typ.any ()) (Typ.any ()))
+            ~pval_type:
+              (Typ.arrow ~arity:(Some 1) Nolabel (Typ.any ()) (Typ.any ()))
             [exp];
         pexp_attributes =
           (match !is_function with
@@ -158,7 +162,8 @@ let handle_raw_structure loc payload =
         exp with
         pexp_desc =
           Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_stmt"]
-            ~pval_type:(Typ.arrow ~arity:None Nolabel (Typ.any ()) (Typ.any ()))
+            ~pval_type:
+              (Typ.arrow ~arity:(Some 1) Nolabel (Typ.any ()) (Typ.any ()))
             [exp];
       }
   | None ->

compiler/frontend/ast_external_process.ml

@@ -934,17 +934,11 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
     Parsetree.core_type * External_ffi_types.t * Parsetree.attributes * bool =
   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]) ->
+    match Ast_uncurried.core_type_remove_function_dollar type_annotation with
+    | {ptyp_desc = Ptyp_arrow (_, _, _, Some _); _} as t ->
       ( t,
         fun ~arity (x : Parsetree.core_type) ->
-          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])} )
+          Ast_uncurried.uncurried_type ~loc ~arity x )
     | _ -> (type_annotation, fun ~arity:_ x -> x)
   in
   let result_type, arg_types_ty =
@@ -961,10 +955,7 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
     let arity, new_type, spec =
       process_obj loc external_desc prim_name arg_types_ty result_type
     in
-    ( build_uncurried_type ~arity:(Some arity) new_type,
-      spec,
-      unused_attrs,
-      false )
+    (build_uncurried_type ~arity new_type, spec, unused_attrs, false)
   else
     let splice = external_desc.splice in
     let arg_type_specs, new_arg_types_ty, arg_type_specs_length =
@@ -1036,7 +1027,7 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
       check_return_wrapper loc external_desc.return_wrapper result_type
     in
     let fn_type = Ast_core_type.mk_fn_type new_arg_types_ty result_type in
-    ( build_uncurried_type ~arity:(Some (List.length new_arg_types_ty)) fn_type,
+    ( build_uncurried_type ~arity:(List.length new_arg_types_ty) fn_type,
       External_ffi_types.ffi_bs arg_type_specs return_wrapper ffi,
       unused_attrs,
       relative )

compiler/gentype/TranslateCoreType.ml

@@ -114,6 +114,7 @@ let rec translate_arrow_type ~config ~type_vars_gen
 and translateCoreType_ ~config ~type_vars_gen
     ?(no_function_return_dependencies = false) ~type_env
     (core_type : Typedtree.core_type) =
+  let core_type = Ast_uncurried.tcore_type_remove_function_dollar core_type in
   match core_type.ctyp_desc with
   | Ttyp_alias (ct, _) ->
     ct