Fix uncurried function type handling in FFI and type system

Fix uncurried function type handling in FFI and type system

This commit improves handling of uncurried function types, particularly in FFI and
the type system:

- Add arity information to @obj externals by returning arity from process_obj
- Fix filter_arrow to properly handle arity in type unification
- Remove invalid assert false in ast_uncurried.ml
- Update type_function and type_application to properly handle arity information
- Pass arity through to is_ignore function for consistent type checking

These changes help ensure proper type checking and arity handling for uncurried
functions, especially in FFI bindings using @obj.

Author: cristianoc

compiler/frontend/ast_external_process.ml

@@ -426,8 +426,8 @@ type response = {
 
 let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
     (arg_types_ty : Ast_core_type.param_type list)
-    (result_type : Ast_core_type.t) : Parsetree.core_type * External_ffi_types.t
-    =
+    (result_type : Ast_core_type.t) :
+    int * Parsetree.core_type * External_ffi_types.t =
   match st with
   | {
    val_name = None;
@@ -610,7 +610,9 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
       (* TODO: do we need do some error checking here *)
       (* result type can not be labeled *)
     in
-    ( Ast_core_type.mk_fn_type new_arg_types_ty result,
+
+    ( List.length new_arg_types_ty,
+      Ast_core_type.mk_fn_type new_arg_types_ty result,
       External_ffi_types.ffi_obj_create arg_kinds )
   | _ -> Location.raise_errorf ~loc "Attribute found that conflicts with %@obj"
 
@@ -961,10 +963,13 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
   in
   if external_desc.mk_obj then
     (* warn unused attributes here ? *)
-    let new_type, spec =
+    let arity, new_type, spec =
       process_obj loc external_desc prim_name arg_types_ty result_type
     in
-    (build_uncurried_type ~arity:None new_type, spec, unused_attrs, false)
+    ( build_uncurried_type ~arity:(Some 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 =

compiler/ml/ast_uncurried.ml

@@ -96,7 +96,6 @@ let make_uncurried_type ~env ~arity (t : Types.type_expr) =
   let t =
     match t.desc with
     | Tarrow (l, t1, t2, c, _) ->
-      let _ = assert false in
       {t with desc = Tarrow (l, t1, t2, c, Some arity)}
     | Tconstr _ -> assert false
     | Tvar _ -> t

compiler/ml/ctype.ml

@@ -2758,15 +2758,13 @@ let expand_head_trace env t =
    (2) the original label is not optional
 *)
 
-let filter_arrow env t l =
+let filter_arrow ~env ~arity t l =
   let t = expand_head_trace env t in
   match t.desc with
   | Tvar _ ->
-    let _ = assert false in
-    (* TODO: need the arity from the function definition *)
     let lv = t.level in
     let t1 = newvar2 lv and t2 = newvar2 lv in
-    let t' = newty2 lv (Tarrow (l, t1, t2, Cok, None)) in
+    let t' = newty2 lv (Tarrow (l, t1, t2, Cok, arity)) in
     link_type t t';
     (t1, t2)
   | Tarrow (l', t1, t2, _, _) when Asttypes.same_arg_label l l' -> (t1, t2)

compiler/ml/ctype.mli

@@ -203,7 +203,8 @@ val unify_var : Env.t -> type_expr -> type_expr -> unit
 val with_passive_variants : ('a -> 'b) -> 'a -> 'b
 (* Call [f] in passive_variants mode, for exhaustiveness check. *)
 
-val filter_arrow : Env.t -> type_expr -> arg_label -> type_expr * type_expr
+val filter_arrow :
+  env:Env.t -> arity:arity -> type_expr -> arg_label -> type_expr * type_expr
 (* A special case of unification (with l:'a -> 'b). *)
 
 val filter_method : Env.t -> string -> private_flag -> type_expr -> type_expr

compiler/ml/typecore.ml

@@ -2225,12 +2225,12 @@ let unify_exp ?type_clash_context env exp expected_ty =
   let loc = proper_exp_loc exp in
   unify_exp_types ?type_clash_context loc env exp.exp_type expected_ty
 
-let is_ignore funct env =
+let is_ignore ~env ~arity funct =
   match funct.exp_desc with
   | Texp_ident (_, _, {val_kind = Val_prim {Primitive.prim_name = "%ignore"}})
     -> (
     try
-      ignore (filter_arrow env (instance env funct.exp_type) Nolabel);
+      ignore (filter_arrow ~env ~arity (instance env funct.exp_type) Nolabel);
       true
     with Unify _ -> false)
   | _ -> false
@@ -3281,7 +3281,7 @@ and type_function ?in_function ~arity loc attrs env ty_expected_ l caselist =
   let separate = Env.has_local_constraints env in
   if separate then begin_def ();
   let ty_arg, ty_res =
-    try filter_arrow env (instance env ty_expected) l
+    try filter_arrow ~env ~arity (instance env ty_expected) l
     with Unify _ -> (
       match expand_head env ty_expected with
       | {desc = Tarrow _} as ty ->
@@ -3310,7 +3310,9 @@ and type_function ?in_function ~arity loc attrs env ty_expected_ l caselist =
     Location.prerr_warning case.c_lhs.pat_loc
       Warnings.Unerasable_optional_argument;
   let param = name_pattern "param" cases in
-  let exp_type = instance env (newgenty (Tarrow (l, ty_arg, ty_res, Cok, assert false))) in
+  let exp_type =
+    instance env (newgenty (Tarrow (l, ty_arg, ty_res, Cok, arity)))
+  in
   let exp_type =
     match arity with
     | None -> exp_type
@@ -3718,11 +3720,14 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) :
                  (List.map Printtyp.string_of_label
                     (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 top_arity = if uncurried then Some max_arity else None in
   match sargs with
   (* Special case for ignore: avoid discarding warning *)
-  | [(Nolabel, sarg)] when is_ignore funct env ->
+  | [(Nolabel, sarg)] when is_ignore ~env ~arity:top_arity funct ->
     let ty_arg, ty_res =
-      filter_arrow env (instance env funct.exp_type) Nolabel
+      filter_arrow ~env ~arity:top_arity (instance env funct.exp_type) Nolabel
     in
     let exp = type_expect env sarg ty_arg in
     (match (expand_head env exp.exp_type).desc with
@@ -3734,9 +3739,6 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) :
     | _ -> ());
     ([(Nolabel, Some exp)], ty_res, false)
   | _ ->
-    if uncurried then force_uncurried_type funct;
-    let ty, max_arity = extract_uncurried_type funct.exp_type in
-    let top_arity = if uncurried then Some max_arity else None in
     let targs, ret_t =
       type_args ?type_clash_context max_arity [] [] ~ty_fun:ty (instance env ty)
         ~sargs ~top_arity