Remove function$ entirely.

Author: cristianoc

analysis/src/CompletionBackEnd.ml

@@ -1358,7 +1358,7 @@ let rec completeTypedValue ?(typeArgContext : typeArgContext option) ~rawOpens
     in
     (* Find all functions in the module that returns type t *)
     let rec fnReturnsTypeT t =
-      match (Ast_uncurried.remove_function_dollar t).desc with
+      match t.Types.desc with
       | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> fnReturnsTypeT t1
       | Tarrow _ -> (
         match TypeUtils.extractFunctionType ~env ~package:full.package t with

analysis/src/CompletionJsx.ml

@@ -234,7 +234,7 @@ let getJsxLabels ~componentPath ~findTypeOfValue ~package =
       | _ -> []
     in
     let rec getLabels (t : Types.type_expr) =
-      match (Ast_uncurried.remove_function_dollar t).desc with
+      match 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) =

analysis/src/CreateInterface.ml

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

analysis/src/SignatureHelp.ml

@@ -105,12 +105,9 @@ let findFunctionType ~currentFile ~debug ~path ~pos =
 let extractParameters ~signature ~typeStrForParser ~labelPrefixLen =
   match signature with
   | [{Parsetree.psig_desc = Psig_value {pval_type = expr}}]
-    when match
-           (Ast_uncurried.core_type_remove_function_dollar expr).ptyp_desc
-         with
+    when match 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

@@ -35,7 +35,7 @@ let findTypeViaLoc ~full ~debug (loc : Location.t) =
   | _ -> None
 
 let pathFromTypeExpr (t : Types.type_expr) =
-  match (Ast_uncurried.remove_function_dollar t).desc with
+  match t.desc with
   | Tconstr (path, _typeArgs, _)
   | Tlink {desc = Tconstr (path, _typeArgs, _)}
   | Tsubst {desc = Tconstr (path, _typeArgs, _)}
@@ -239,7 +239,7 @@ let rec extractObjectType ~env ~package (t : Types.type_expr) =
 
 let extractFunctionType ~env ~package typ =
   let rec loop ~env acc (t : Types.type_expr) =
-    match (Ast_uncurried.remove_function_dollar t).desc with
+    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 (path, typeArgs, _) -> (
@@ -276,7 +276,7 @@ let maybeSetTypeArgCtx ?typeArgContextFromTypeManifest ~typeParams ~typeArgs env
 (* 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 extractFunctionType2 ?typeArgContext ~env ~package typ =
   let rec loop ?typeArgContext ~env acc (t : Types.type_expr) =
-    match (Ast_uncurried.remove_function_dollar t).desc with
+    match 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
@@ -312,7 +312,7 @@ let rec extractType ?(printOpeningDebug = true)
       Printf.printf "[extract_type]--> %s"
         (debugLogTypeArgContext typeArgContext));
   let instantiateType = instantiateType2 in
-  match (Ast_uncurried.remove_function_dollar t).desc with
+  match t.desc with
   | Tlink t1 | Tsubst t1 | Tpoly (t1, []) ->
     extractType ?typeArgContext ~printOpeningDebug:false ~env ~package t1
   | Tconstr (Path.Pident {name = "option"}, [payloadTypeExpr], _) ->
@@ -894,7 +894,7 @@ 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 (Ast_uncurried.remove_function_dollar t).desc with
+    match t.desc with
     | Tlink t1 | Tsubst t1 | Tpoly (t1, []) ->
       getArgsLoop ~full ~env ~currentArgumentPosition t1
     | Tarrow (Labelled l, tArg, tRet, _, _) ->

compiler/frontend/ast_core_type.ml

@@ -124,8 +124,8 @@ let get_uncurry_arity (ty : t) =
   | _ -> None
 
 let get_curry_arity (ty : t) =
-  match Ast_uncurried.core_type_remove_function_dollar ty with
-  | {ptyp_desc = Ptyp_arrow (_, _, _, Some arity)} -> arity
+  match ty.ptyp_desc with
+  | Ptyp_arrow (_, _, _, Some arity) -> arity
   | _ -> get_uncurry_arity_aux ty 0
 
 let is_arity_one ty = get_curry_arity ty = 1
@@ -156,7 +156,7 @@ let mk_fn_type (new_arg_types_ty : param_type list) (result : t) : t =
 let list_of_arrow (ty : t) : t * param_type list =
   let rec aux (ty : t) acc =
     match ty.ptyp_desc with
-    | Ptyp_arrow (label, t1, t2, _) ->
+    | Ptyp_arrow (label, t1, t2, arity) when arity = None || acc = [] ->
       aux t2
         (({label; ty = t1; attr = ty.ptyp_attributes; loc = ty.ptyp_loc}
            : param_type)

compiler/frontend/ast_core_type_class_type.ml

@@ -66,7 +66,7 @@ let default_typ_mapper = Bs_ast_mapper.default_mapper.typ
 
 let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) =
   let loc = ty.ptyp_loc in
-  match (Ast_uncurried.core_type_remove_function_dollar ty).ptyp_desc with
+  match 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

compiler/frontend/ast_derive_js_mapper.ml

@@ -130,7 +130,7 @@ let app1 = Ast_compatible.app1
 let app2 = Ast_compatible.app2
 
 let ( ->~ ) a b =
-  Ast_uncurried.uncurried_type ~loc:Location.none ~arity:1
+  Ast_uncurried.uncurried_type ~arity:1
     (Ast_compatible.arrow ~arity:(Some 1) a b)
 
 let raise_when_not_found_ident =
@@ -295,7 +295,7 @@ let init () =
               let pat_from_js = {Asttypes.loc; txt = from_js} in
               let to_js_type result =
                 Ast_comb.single_non_rec_val pat_to_js
-                  (Ast_uncurried.uncurried_type ~loc:Location.none ~arity:1
+                  (Ast_uncurried.uncurried_type ~arity:1
                      (Ast_compatible.arrow ~arity:(Some 1) core_type result))
               in
               let new_type, new_tdcl =

compiler/frontend/ast_derive_projector.ml

@@ -120,9 +120,8 @@ let init () =
             Ext_list.flat_map tdcls handle_tdcl);
         signature_gen =
           (fun (tdcls : Parsetree.type_declaration list) _explict_nonrec ->
-            let handle_uncurried_type_tranform ~loc ~arity t =
-              if arity > 0 then Ast_uncurried.uncurried_type ~loc ~arity t
-              else t
+            let handle_uncurried_type_tranform ~arity t =
+              if arity > 0 then Ast_uncurried.uncurried_type ~arity t else t
             in
             let handle_tdcl tdcl =
               let core_type =
@@ -142,8 +141,7 @@ let init () =
                     Ast_comb.single_non_rec_val ?attrs:gentype_attrs pld_name
                       (Ast_compatible.arrow ~arity:None core_type pld_type
                       (*arity will alwys be 1 since these are single param functions*)
-                      |> handle_uncurried_type_tranform ~arity:1
-                           ~loc:pld_name.loc))
+                      |> handle_uncurried_type_tranform ~arity:1))
               | Ptype_variant constructor_declarations ->
                 Ext_list.map constructor_declarations
                   (fun
@@ -170,7 +168,7 @@ let init () =
                       {loc; txt = Ext_string.uncapitalize_ascii con_name}
                       (Ext_list.fold_right pcd_args annotate_type (fun x acc ->
                            Ast_compatible.arrow ~arity:None x acc)
-                      |> handle_uncurried_type_tranform ~arity ~loc))
+                      |> handle_uncurried_type_tranform ~arity))
               | Ptype_open | Ptype_abstract ->
                 Ast_derive_util.not_applicable tdcl.ptype_loc deriving_name;
                 []

compiler/frontend/ast_exp_handle_external.ml

@@ -133,7 +133,7 @@ let handle_ffi ~loc ~payload =
       match !is_function with
       | Some arity ->
         let type_ =
-          Ast_uncurried.uncurried_type ~loc
+          Ast_uncurried.uncurried_type
             ~arity:(if arity = 0 then 1 else arity)
             (arrow ~arity)
         in

compiler/frontend/ast_external_process.ml

@@ -934,11 +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 Ast_uncurried.core_type_remove_function_dollar type_annotation with
+    match type_annotation with
     | {ptyp_desc = Ptyp_arrow (_, _, _, Some _); _} as t ->
       ( t,
         fun ~arity (x : Parsetree.core_type) ->
-          Ast_uncurried.uncurried_type ~loc ~arity x )
+          Ast_uncurried.uncurried_type ~arity x )
     | _ -> (type_annotation, fun ~arity:_ x -> x)
   in
   let result_type, arg_types_ty =

compiler/frontend/ast_typ_uncurry.ml

@@ -66,5 +66,5 @@ let to_uncurry_type loc (mapper : Bs_ast_mapper.mapper)
     | _ -> assert false
   in
   match arity with
-  | Some arity -> Ast_uncurried.uncurried_type ~loc ~arity fn_type
+  | Some arity -> Ast_uncurried.uncurried_type ~arity fn_type
   | None -> assert false

compiler/gentype/TranslateCoreType.ml

@@ -52,7 +52,8 @@ let rec translate_arrow_type ~config ~type_vars_gen
     ~no_function_return_dependencies ~type_env ~rev_arg_deps ~rev_args
     (core_type : Typedtree.core_type) =
   match core_type.ctyp_desc with
-  | Ttyp_arrow (Nolabel, core_type1, core_type2, _) ->
+  | Ttyp_arrow (Nolabel, core_type1, core_type2, arity)
+    when arity = None || rev_args = [] ->
     let {dependencies; type_} =
       core_type1 |> fun __x ->
       translateCoreType_ ~config ~type_vars_gen ~type_env __x
@@ -63,7 +64,8 @@ let rec translate_arrow_type ~config ~type_vars_gen
          ~no_function_return_dependencies ~type_env ~rev_arg_deps:next_rev_deps
          ~rev_args:((Nolabel, type_) :: rev_args)
   | Ttyp_arrow
-      (((Labelled lbl | Optional lbl) as label), core_type1, core_type2, _) -> (
+      (((Labelled lbl | Optional lbl) as label), core_type1, core_type2, arity)
+    when arity = None || rev_args = [] -> (
     let as_label =
       match core_type.ctyp_attributes |> Annotation.get_gentype_as_renaming with
       | Some s -> s
@@ -114,7 +116,6 @@ 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

compiler/gentype/TranslateTypeExprFromTypes.ml

@@ -268,7 +268,8 @@ let rec translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps
   | Tlink t ->
     translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps
       ~rev_args t
-  | Tarrow (Nolabel, type_expr1, type_expr2, _, _) ->
+  | Tarrow (Nolabel, type_expr1, type_expr2, _, arity)
+    when arity = None || rev_args = [] ->
     let {dependencies; type_} =
       type_expr1 |> fun __x ->
       translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env __x
@@ -279,8 +280,12 @@ let rec translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps
          ~rev_arg_deps:next_rev_deps
          ~rev_args:((Nolabel, type_) :: rev_args)
   | Tarrow
-      (((Labelled lbl | Optional lbl) as label), type_expr1, type_expr2, _, _)
-    -> (
+      ( ((Labelled lbl | Optional lbl) as label),
+        type_expr1,
+        type_expr2,
+        _,
+        arity )
+    when arity = None || rev_args = [] -> (
     match type_expr1 |> remove_option ~label with
     | None ->
       let {dependencies; type_ = type1} =
@@ -312,8 +317,7 @@ let rec translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps
     {dependencies = all_deps; type_ = function_type}
 
 and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env
-    (type_expr_ : Types.type_expr) =
-  let type_expr = Ast_uncurried.remove_function_dollar type_expr_ in
+    (type_expr : Types.type_expr) =
   match type_expr.desc with
   | Tvar None ->
     let type_name =

compiler/ml/ast_mapper_from0.ml

@@ -120,10 +120,7 @@ module T = struct
           | _ -> assert false
         in
         let arity = arity_from_type t_arity in
-        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])}
+        {fun_t with ptyp_desc = Ptyp_arrow (lbl, t1, t2, Some arity)}
       | _ -> typ0)
     | Ptyp_object (l, o) ->
       object_ ~loc ~attrs (List.map (object_field sub) l) o

compiler/ml/ast_mapper_to0.ml

@@ -98,20 +98,21 @@ module T = struct
     match desc with
     | Ptyp_any -> any ~loc ~attrs ()
     | Ptyp_var s -> var ~loc ~attrs s
-    | Ptyp_arrow (lab, t1, t2, _) ->
-      arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
+    | Ptyp_arrow (lab, t1, t2, arity) -> (
+      let typ0 = arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) in
+      match arity with
+      | None -> typ0
+      | Some arity ->
+        let arity_string = "Has_arity" ^ string_of_int arity in
+        let arity_type =
+          Ast_helper0.Typ.variant ~loc
+            [Rtag (Location.mknoloc arity_string, [], true, [])]
+            Closed None
+        in
+        Ast_helper0.Typ.constr ~loc
+          {txt = Lident "function$"; loc}
+          [typ0; arity_type])
     | 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,13 +1,10 @@
 (* Uncurried AST *)
 
-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
-  Ast_helper.Typ.constr ~loc {txt = Lident "function$"; loc} [t_arg]
+let uncurried_type ~arity (t_arg : Parsetree.core_type) =
+  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
 
 let uncurried_fun ~arity fun_expr =
   let fun_expr =
@@ -43,45 +40,8 @@ let tarrow_to_arity_opt (t_arity : Types.type_expr) =
   | Tarrow (_, _, _, _, arity) -> arity
   | _ -> None
 
-let make_uncurried_type ~env ~arity (t : Types.type_expr) =
-  let lid : Longident.t = Lident "function$" in
-  let path = Env.lookup_type lid env in
-  let t =
-    match t.desc with
-    | Tarrow (l, t1, t2, c, _) ->
-      {t with desc = Tarrow (l, t1, t2, c, Some arity)}
-    | Tconstr _ -> assert false
-    | Tvar _ -> t
-    | _ -> assert false
-  in
-  Ctype.newconstr path [t]
-
 let uncurried_type_get_arity ~env typ =
-  match (Ctype.expand_head env typ).desc with
-  | Tconstr (Pident {name = "function$"}, [t], _) -> tarrow_to_arity t
-  | _ -> assert false
+  tarrow_to_arity (Ctype.expand_head env typ)
 
 let uncurried_type_get_arity_opt ~env typ =
-  match (Ctype.expand_head env typ).desc with
-  | Tconstr (Pident {name = "function$"}, [t], _) -> Some (tarrow_to_arity t)
-  | _ -> None
-
-let remove_function_dollar ?env typ =
-  match
-    (match env with
-    | Some env -> Ctype.expand_head env typ
-    | None -> Ctype.repr typ)
-      .desc
-  with
-  | Tconstr (Pident {name = "function$"}, [t], _) -> t
-  | _ -> typ
-
-let core_type_remove_function_dollar (typ : Parsetree.core_type) =
-  match typ.ptyp_desc with
-  | Ptyp_constr ({txt = Lident "function$"}, [t]) -> t
-  | _ -> typ
-
-let tcore_type_remove_function_dollar (typ : Typedtree.core_type) =
-  match typ.ctyp_desc with
-  | Ttyp_constr (Pident {name = "function$"}, _, [t]) -> t
-  | _ -> typ
+  tarrow_to_arity_opt (Ctype.expand_head env typ)

compiler/ml/ast_untagged_variants.ml

@@ -188,7 +188,6 @@ let type_to_instanceof_backed_obj (t : Types.type_expr) =
 
 let get_block_type_from_typ ~env (t : Types.type_expr) : block_type option =
   let t = !expand_head env t in
-  let t = Tmp_uncurried.remove_function_dollar t in
   match t with
   | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_string ->
     Some StringType