Remove function$ entirely.

Author: cristianoc

compiler/frontend/ast_core_type.ml

@@ -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/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

@@ -7,7 +7,8 @@ let uncurried_type ~loc ~arity (t_arg : Parsetree.core_type) =
       {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 _ = loc in
+  t_arg
 
 let uncurried_fun ~arity fun_expr =
   let fun_expr =
@@ -44,8 +45,9 @@ let tarrow_to_arity_opt (t_arity : Types.type_expr) =
   | _ -> 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 lid : Longident.t = Lident "function$" in
+     let path = Env.lookup_type lid env in *)
+  let _ = env in
   let t =
     match t.desc with
     | Tarrow (l, t1, t2, c, _) ->
@@ -54,17 +56,13 @@ let make_uncurried_type ~env ~arity (t : Types.type_expr) =
     | Tvar _ -> t
     | _ -> assert false
   in
-  Ctype.newconstr path [t]
+  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
+  tarrow_to_arity_opt (Ctype.expand_head env typ)
 
 let remove_function_dollar ?env typ =
   match
@@ -73,15 +71,12 @@ let remove_function_dollar ?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

compiler/ml/oprint.ml

@@ -249,7 +249,7 @@ let rec print_out_type ppf = function
   | ty -> print_out_type_1 ppf ty
 
 and print_out_type_1 ppf = function
-  | Otyp_arrow (lab, ty1, ty2) ->
+  | Otyp_arrow (lab, ty1, ty2, _) ->
     pp_open_box ppf 0;
     if lab <> "" then (
       pp_print_string ppf lab;
@@ -271,24 +271,6 @@ and print_simple_out_type ppf = function
     fprintf ppf "@[%a%s#%a@]" print_typargs tyl
       (if ng then "_" else "")
       print_ident id
-  | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), name), [tyl]) ->
-    let res =
-      if name = "arity0" then
-        Otyp_arrow ("", Otyp_constr (Oide_ident "unit", []), tyl)
-      else tyl
-    in
-    fprintf ppf "@[<0>(%a@ [@bs])@]" print_out_type_1 res
-  | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js_OO", "Meth"), name), [tyl])
-    ->
-    let res =
-      if name = "arity0" then
-        Otyp_arrow ("", Otyp_constr (Oide_ident "unit", []), tyl)
-      else tyl
-    in
-    fprintf ppf "@[<0>(%a@ [@meth])@]" print_out_type_1 res
-  | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js_OO", "Callback"), _), [tyl])
-    ->
-    fprintf ppf "@[<0>(%a@ [@this])@]" print_out_type_1 tyl
   | Otyp_constr (id, tyl) ->
     pp_open_box ppf 0;
     print_typargs ppf tyl;

compiler/ml/outcometree.ml

@@ -53,7 +53,7 @@ type out_type =
   | Otyp_abstract
   | Otyp_open
   | Otyp_alias of out_type * string
-  | Otyp_arrow of string * out_type * out_type
+  | Otyp_arrow of string * out_type * out_type * Asttypes.arity
   | Otyp_class of bool * out_ident * out_type list
   | Otyp_constr of out_ident * out_type list
   | Otyp_manifest of out_type * out_type

compiler/ml/parsetree.ml

@@ -224,8 +224,7 @@ and expression_desc =
     (* let P1 = E1 and ... and Pn = EN in E       (flag = Nonrecursive)
        let rec P1 = E1 and ... and Pn = EN in E   (flag = Recursive)
     *)
-  | Pexp_fun of
-      arg_label * expression option * pattern * expression * int option
+  | Pexp_fun of arg_label * expression option * pattern * expression * arity
     (* fun P -> E1                          (Simple, None)
        fun ~l:P -> E1                       (Labelled l, None)
        fun ?l:P -> E1                       (Optional l, None)

compiler/ml/printtyp.ml

@@ -587,7 +587,7 @@ let rec tree_of_typexp sch ty =
         let non_gen = is_non_gen sch ty in
         let name_gen = if non_gen then new_weak_name ty else new_name in
         Otyp_var (non_gen, name_of_type name_gen ty)
-      | Tarrow (l, ty1, ty2, _, _) ->
+      | Tarrow (l, ty1, ty2, _, arity) ->
         let pr_arrow l ty1 ty2 =
           let lab = string_of_label l in
           let t1 =
@@ -599,7 +599,8 @@ let rec tree_of_typexp sch ty =
               | _ -> Otyp_stuff "<hidden>"
             else tree_of_typexp sch ty1
           in
-          Otyp_arrow (lab, t1, tree_of_typexp sch ty2)
+          (* should pass arity here? *)
+          Otyp_arrow (lab, t1, tree_of_typexp sch ty2, arity)
         in
         pr_arrow l ty1 ty2
       | Ttuple tyl -> Otyp_tuple (tree_of_typlist sch tyl)

compiler/ml/typecore.ml

@@ -75,7 +75,6 @@ type error =
   | Literal_overflow of string
   | Unknown_literal of string * char
   | Illegal_letrec_pat
-  | Labels_omitted of string list
   | Empty_record_literal
   | Uncurried_arity_mismatch of type_expr * int * int
   | Field_not_optional of string * type_expr
@@ -1945,7 +1944,7 @@ let rec list_labels_aux env visited ls ty_fun =
   if List.memq ty visited then (List.rev ls, false)
   else
     match ty.desc with
-    | Tarrow (l, _, ty_res, _, _) ->
+    | Tarrow (l, _, ty_res, _, arity) when arity = None || visited = [] ->
       list_labels_aux env (ty :: visited) (l :: ls) ty_res
     | _ -> (List.rev ls, is_Tvar ty)
 
@@ -3539,7 +3538,7 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) :
       in
       unify_exp env funct uncurried_typ
     else if
-      Ast_uncurried.tarrow_to_arity_opt
+      Ast_uncurried.uncurried_type_get_arity_opt ~env
         (Ast_uncurried.remove_function_dollar ~env funct.exp_type)
       = None
     then
@@ -3700,23 +3699,6 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) :
       type_unknown_args max_arity ~args ~top_arity omitted ty_fun0
         sargs (* This is the hot path for non-labeled function*)
   in
-  let () =
-    let ls, tvar = list_labels env funct.exp_type in
-    if not tvar then
-      let labels = Ext_list.filter ls (fun l -> not (is_optional l)) in
-      if
-        Ext_list.same_length labels sargs
-        && List.for_all (fun (l, _) -> l = Nolabel) sargs
-        && List.exists (fun l -> l <> Nolabel) labels
-      then
-        raise
-          (Error
-             ( funct.exp_loc,
-               env,
-               Labels_omitted
-                 (List.map Printtyp.string_of_label
-                    (Ext_list.filter labels (fun x -> x <> Nolabel))) ))
-  in
   if total_app then force_uncurried_type funct;
   let ty, max_arity = extract_uncurried_type funct in
   let top_arity = if total_app then Some max_arity else None in
@@ -3728,7 +3710,7 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) :
     in
     let exp = type_expect env sarg ty_arg in
     (match (expand_head env exp.exp_type).desc with
-    | Tarrow _ ->
+    | Tarrow _ when not total_app ->
       Location.prerr_warning exp.exp_loc Warnings.Partial_application
     | Tvar _ ->
       Delayed_checks.add_delayed_check (fun () ->
@@ -4345,23 +4327,6 @@ let report_error env ppf error =
     let arity_a = arity_a |> string_of_int in
     let arity_b = arity_b |> string_of_int in
     report_arity_mismatch ~arity_a ~arity_b ppf
-  | Expr_type_clash
-      ( ( _,
-          {
-            desc =
-              Tconstr
-                (Pdot (Pdot (Pident {name = "Js_OO"}, "Meth", _), a, _), _, _);
-          } )
-        :: ( _,
-             {
-               desc =
-                 Tconstr
-                   (Pdot (Pdot (Pident {name = "Js_OO"}, "Meth", _), b, _), _, _);
-             } )
-        :: _,
-        _ )
-    when a <> b ->
-    fprintf ppf "This method has %s but was expected %s" a b
   | Expr_type_clash (trace, type_clash_context) ->
     (* modified *)
     fprintf ppf "@[<v>";
@@ -4544,16 +4509,6 @@ let report_error env ppf error =
     fprintf ppf "Unknown modifier '%c' for literal %s%c" m n m
   | Illegal_letrec_pat ->
     fprintf ppf "Only variables are allowed as left-hand side of `let rec'"
-  | Labels_omitted [label] ->
-    fprintf ppf
-      "Label ~%s was omitted in the application of this labeled function." label
-  | Labels_omitted labels ->
-    let labels_string =
-      labels |> List.map (fun label -> "~" ^ label) |> String.concat ", "
-    in
-    fprintf ppf
-      "Labels %s were omitted in the application of this labeled function."
-      labels_string
   | Empty_record_literal ->
     fprintf ppf
       "Empty record literal {} should be type annotated or used in a record \

compiler/ml/typecore.mli

@@ -118,7 +118,6 @@ type error =
   | Literal_overflow of string
   | Unknown_literal of string * char
   | Illegal_letrec_pat
-  | Labels_omitted of string list
   | Empty_record_literal
   | Uncurried_arity_mismatch of type_expr * int * int
   | Field_not_optional of string * type_expr

compiler/ml/typedtree.ml

@@ -78,7 +78,7 @@ and expression_desc =
   | Texp_let of rec_flag * value_binding list * expression
   | Texp_function of {
       arg_label: arg_label;
-      arity: int option;
+      arity: arity;
       param: Ident.t;
       case: case;
       partial: partial;

compiler/ml/typedtree.mli

@@ -132,7 +132,7 @@ and expression_desc =
          *)
   | Texp_function of {
       arg_label: arg_label;
-      arity: int option;
+      arity: arity;
       param: Ident.t;
       case: case;
       partial: partial;

compiler/syntax/src/res_outcome_printer.ml

@@ -82,7 +82,8 @@ let print_out_attributes_doc (attrs : Outcometree.out_attribute list) =
 
 let rec collect_arrow_args (out_type : Outcometree.out_type) args =
   match out_type with
-  | Otyp_arrow (label, arg_type, return_type) ->
+  | Otyp_arrow (label, arg_type, return_type, arity)
+    when arity = None || args = [] ->
     let arg = (label, arg_type) in
     collect_arrow_args return_type (arg :: args)
   | _ as return_type -> (List.rev args, return_type)
@@ -147,21 +148,6 @@ let rec print_out_type_doc (out_type : Outcometree.out_type) =
         Doc.text alias_txt;
         Doc.rparen;
       ]
-  | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), "arity0"), [typ])
-    ->
-    (* Compatibility with compiler up to v10.x *)
-    Doc.concat [Doc.text "(. ()) => "; print_out_type_doc typ]
-  | Otyp_constr
-      ( Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), _),
-        [(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)]) ->
-    (* function$<(int, int) => int> -> (int, int) => int *)
-    print_out_arrow_type arrow_type
-  | Otyp_constr (Oide_ident "function$", [Otyp_var _]) ->
-    (* function$<'a, arity> -> _ => _ *)
-    print_out_type_doc (Otyp_stuff "_ => _")
   | Otyp_constr (out_ident, []) ->
     print_out_ident_doc ~allow_uident:false out_ident
   | Otyp_manifest (typ1, typ2) ->
@@ -295,12 +281,7 @@ and print_out_arrow_type typ =
   let args_doc =
     let needs_parens =
       match typ_args with
-      | [
-       ( _,
-         ( Otyp_tuple _ | Otyp_arrow _
-         | Otyp_constr (Oide_ident "function$", [Otyp_arrow _]) ) );
-      ] ->
-        true
+      | [(_, (Otyp_tuple _ | Otyp_arrow _))] -> true
       (* single argument should not be wrapped *)
       | [("", _)] -> false
       | _ -> true

compiler/syntax/src/res_parsetree_viewer.ml

@@ -1,12 +1,15 @@
 open Parsetree
 
-let arrow_type ?(max_arity = max_int) ?(attrs = []) ct =
+let arrow_type ?(max_arity = max_int) ct =
   let has_as_attr attrs =
     Ext_list.exists attrs (fun (x, _) -> x.Asttypes.txt = "as")
   in
   let rec process attrs_before acc typ arity =
     match typ with
-    | typ when arity < 0 -> (attrs_before, List.rev acc, typ)
+    | _ when arity < 0 -> (attrs_before, List.rev acc, typ)
+    | {ptyp_desc = Ptyp_arrow (_, _, _, Some _); ptyp_attributes = []}
+      when acc <> [] ->
+      (attrs_before, List.rev acc, typ)
     | {
      ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2, _);
      ptyp_attributes = [];
@@ -51,9 +54,8 @@ let arrow_type ?(max_arity = max_int) ?(attrs = []) ct =
       ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2, _);
       ptyp_attributes = attrs1;
     } as typ ->
-    let attrs = attrs @ attrs1 in
-    process attrs [] {typ with ptyp_attributes = []} max_arity
-  | typ -> process attrs [] typ max_arity
+    process attrs1 [] {typ with ptyp_attributes = []} max_arity
+  | typ -> process [] [] typ max_arity
 
 let functor_type modtype =
   let rec process acc modtype =

compiler/syntax/src/res_parsetree_viewer.mli

@@ -3,7 +3,6 @@
    * we restructure the tree into (a, b, c) and its returnType d *)
 val arrow_type :
   ?max_arity:int ->
-  ?attrs:Parsetree.attributes ->
   Parsetree.core_type ->
   Parsetree.attributes
   * (Parsetree.attributes * Asttypes.arg_label * Parsetree.core_type) list