Remove remaining uses of type_to_arity.

Author: cristianoc

compiler/ml/ast_uncurried.ml

@@ -78,16 +78,18 @@ let arity_to_type arity =
          row_name = None;
        })
 
-let type_to_arity (t_arity : Types.type_expr) =
-  match (Ctype.repr t_arity).desc with
-  | Tvariant {row_fields = [(label, _)]} -> decode_arity_string label
-  | _ -> assert false
-
-let fun_type_to_arity (t_arity : Types.type_expr) =
+let tarrow_to_arity (t_arity : Types.type_expr) =
   match (Ctype.repr t_arity).desc with
   | Tarrow (_, _, _, _, Some arity) -> arity
   | Tarrow _ -> assert false
-  | _ -> assert false
+  | _ ->
+    Format.eprintf "t: %a@." Printtyp.raw_type_expr t_arity;
+    assert false
+
+let tarrow_to_arity_opt (t_arity : Types.type_expr) =
+  match (Ctype.repr t_arity).desc with
+  | Tarrow (_, _, _, _, arity) -> arity
+  | _ -> None
 
 let make_uncurried_type ~env ~arity (t : Types.type_expr) =
   let typ_arity = arity_to_type arity in
@@ -105,11 +107,11 @@ let make_uncurried_type ~env ~arity (t : Types.type_expr) =
 
 let uncurried_type_get_arity ~env typ =
   match (Ctype.expand_head env typ).desc with
-  | Tconstr (Pident {name = "function$"}, [t; _arity], _) -> fun_type_to_arity t
+  | Tconstr (Pident {name = "function$"}, [t; _arity], _) -> 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 (fun_type_to_arity t)
+    Some (tarrow_to_arity t)
   | _ -> None

compiler/ml/ctype.ml

@@ -2310,10 +2310,11 @@ and unify3 env t1 t1' t2 t2' =
     | Pattern -> add_type_equality t1' t2');
     try
       (match (d1, d2) with
-      | Tarrow (l1, t1, u1, c1, _), Tarrow (l2, t2, u2, c2, _)
-        when Asttypes.same_arg_label l1 l2
-             || (!umode = Pattern && not (is_optional l1 || is_optional l2))
-        -> (
+      | Tarrow (l1, t1, u1, c1, a1), Tarrow (l2, t2, u2, c2, a2)
+        when a1 = a2
+             && (Asttypes.same_arg_label l1 l2
+                || (!umode = Pattern && not (is_optional l1 || is_optional l2))
+                ) -> (
         unify env t1 t2;
         unify env u1 u2;
         match (commu_repr c1, commu_repr c2) with

compiler/ml/printtyp.ml

@@ -146,6 +146,10 @@ let string_of_label = function
   | Labelled s -> s
   | Optional s -> "?" ^ s
 
+let string_of_arity = function
+  | None -> ""
+  | Some arity -> string_of_int arity
+
 let visited = ref []
 let rec raw_type ppf ty =
   let ty = safe_repr [] ty in
@@ -159,9 +163,10 @@ and raw_type_list tl = raw_list raw_type tl
 
 and raw_type_desc ppf = function
   | Tvar name -> fprintf ppf "Tvar %a" print_name name
-  | Tarrow (l, t1, t2, c, _) ->
-    fprintf ppf "@[<hov1>Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" (string_of_label l)
-      raw_type t1 raw_type t2 (safe_commu_repr [] c)
+  | Tarrow (l, t1, t2, c, a) ->
+    fprintf ppf "@[<hov1>Tarrow(\"%s\",@,%a,@,%a,@,%s,@,%s)@]"
+      (string_of_label l) raw_type t1 raw_type t2 (safe_commu_repr [] c)
+      (string_of_arity a)
   | Ttuple tl -> fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl
   | Tconstr (p, tl, abbrev) ->
     fprintf ppf "@[<hov1>Tconstr(@,%a,@,%a,@,%a)@]" path p raw_type_list tl

compiler/ml/typecore.ml

@@ -315,8 +315,6 @@ let unify_pat_types loc env ty ty' =
 
 (* unification inside type_exp and type_expect *)
 let unify_exp_types ?type_clash_context loc env ty expected_ty =
-  (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
-     Printtyp.raw_type_expr expected_ty; *)
   try unify env ty expected_ty with
   | Unify trace ->
     raise (Error (loc, env, Expr_type_clash (trace, type_clash_context)))
@@ -3268,7 +3266,7 @@ and type_function ?in_function ~arity loc attrs env ty_expected_ l caselist =
     match arity with
     | None -> ty_expected_
     | Some arity ->
-      let fun_t = newvar () in
+      let fun_t = newty (Tarrow (l, newvar (), newvar (), Cok, Some arity)) in
       let uncurried_typ = Ast_uncurried.make_uncurried_type ~env ~arity fun_t in
       unify_exp_types loc env uncurried_typ ty_expected_;
       fun_t
@@ -3519,7 +3517,6 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression)
 
 and type_application ?type_clash_context uncurried env funct (sargs : sargs) :
     targs * Types.type_expr * bool =
-  (* funct.exp_type may be generic *)
   let result_type omitted ty_fun =
     List.fold_left
       (fun ty_fun (l, ty, lv) -> newty2 lv (Tarrow (l, ty, ty_fun, Cok, None)))
@@ -3530,15 +3527,20 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) :
     tvar || List.mem l ls
   in
   let ignored = ref [] in
-  let has_uncurried_type t =
+  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], _) ->
-      let arity = Ast_uncurried.type_to_arity t_arity in
+    | Tconstr (Pident {name = "function$"}, [t; _t_arity], _) ->
+      let arity =
+        match Ast_uncurried.tarrow_to_arity_opt t with
+        | Some arity -> arity
+        | None -> List.length sargs
+      in
       Some (arity, t)
     | _ -> None
   in
   let force_uncurried_type funct =
-    match has_uncurried_type funct.exp_type with
+    match has_uncurried_type funct with
     | None -> (
       let arity = List.length sargs in
       let uncurried_typ =
@@ -3554,8 +3556,9 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) :
                Apply_non_function (expand_head env funct.exp_type) )))
     | Some _ -> ()
   in
-  let extract_uncurried_type t =
-    match has_uncurried_type t with
+  let extract_uncurried_type funct =
+    let t = funct.exp_type in
+    match has_uncurried_type funct with
     | Some (arity, t1) ->
       if List.length sargs > arity then
         raise
@@ -3566,8 +3569,8 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) :
       (t1, arity)
     | None -> (t, max_int)
   in
-  let update_uncurried_arity ~nargs t new_t =
-    match has_uncurried_type t with
+  let update_uncurried_arity ~nargs funct new_t =
+    match has_uncurried_type funct with
     | Some (arity, _) ->
       let newarity = arity - nargs in
       let fully_applied = newarity <= 0 in
@@ -3576,7 +3579,8 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) :
           (Error
              ( funct.exp_loc,
                env,
-               Uncurried_arity_mismatch (t, arity, List.length sargs) ));
+               Uncurried_arity_mismatch
+                 (funct.exp_type, arity, List.length sargs) ));
       let new_t =
         if fully_applied then new_t
         else Ast_uncurried.make_uncurried_type ~env ~arity:newarity new_t
@@ -3721,7 +3725,7 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) :
                     (Ext_list.filter labels (fun x -> x <> Nolabel))) ))
   in
   if uncurried then force_uncurried_type funct;
-  let ty, max_arity = extract_uncurried_type funct.exp_type in
+  let ty, max_arity = extract_uncurried_type funct in
   let top_arity = if uncurried then Some max_arity else None in
   match sargs with
   (* Special case for ignore: avoid discarding warning *)
@@ -3744,7 +3748,7 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) :
         ~sargs ~top_arity
     in
     let fully_applied, ret_t =
-      update_uncurried_arity funct.exp_type
+      update_uncurried_arity funct
         ~nargs:(List.length !ignored + List.length sargs)
         ret_t
     in
@@ -4340,13 +4344,27 @@ let report_error env ppf = function
       "This function is an uncurried function where a curried function is \
        expected"
   | Expr_type_clash
-      ( (_, {desc = Tconstr (Pident {name = "function$"}, [_; t_a], _)})
-        :: (_, {desc = Tconstr (Pident {name = "function$"}, [_; t_b], _)})
+      ( ( _,
+          {
+            desc =
+              Tconstr
+                ( Pident {name = "function$"},
+                  [{desc = Tarrow (_, _, _, _, Some arity_a)}; _],
+                  _ );
+          } )
+        :: ( _,
+             {
+               desc =
+                 Tconstr
+                   ( Pident {name = "function$"},
+                     [{desc = Tarrow (_, _, _, _, Some arity_b)}; _],
+                     _ );
+             } )
         :: _,
         _ )
-    when Ast_uncurried.type_to_arity t_a <> Ast_uncurried.type_to_arity t_b ->
-    let arity_a = Ast_uncurried.type_to_arity t_a |> string_of_int in
-    let arity_b = Ast_uncurried.type_to_arity t_b |> string_of_int in
+    when arity_a <> arity_b ->
+    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
       ( ( _,