Refactor method callback and uncurry type handling

cristianoc · cristianoc · commit 8a7ac4a19d1a · 2025-07-20T18:06:40.000+02:00
Simplifies and updates the handling of method callback and uncurry types in the AST frontend. Removes the to_uncurry_type function and refactors to_method_callback_type to accept arity and the full method type, improving compatibility and maintainability. Updates related type signatures and usage in core type class and uncurry generation modules.
diff --git a/compiler/frontend/ast_core_type_class_type.ml b/compiler/frontend/ast_core_type_class_type.ml
@@ -67,17 +67,15 @@ 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 ty.ptyp_desc with
-  | Ptyp_arrow {arg; ret = body}
+  | Ptyp_arrow {arity}
   (* 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 arg.lbl arg.typ body
-    | Method _ ->
-      (* Treat @meth as making the type uncurried, for backwards compatibility *)
-      Ast_typ_uncurry.to_uncurry_type loc self arg.lbl arg.typ body
+      Ast_typ_uncurry.to_method_callback_type loc self ~arity ty
+    | Method _ -> Bs_ast_mapper.default_mapper.typ self ty
     | Nothing -> Bs_ast_mapper.default_mapper.typ self ty)
   | Ptyp_object (methods, closed_flag) ->
     let ( +> ) attr (typ : Parsetree.core_type) =
@@ -107,7 +105,8 @@ let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) =
                 | Meth_callback attr, attrs -> (attrs, attr +> ty)
               in
               Ast_compatible.object_field name attrs
-                (Ast_typ_uncurry.to_uncurry_type loc self Nolabel core_type
+                (Ast_helper.Typ.arrows ~loc
+                   [{attrs = []; lbl = Nolabel; typ = self.typ self core_type}]
                    (Ast_literal.type_unit ~loc ()))
             in
             let not_getter_setter ty =
diff --git a/compiler/frontend/ast_typ_uncurry.ml b/compiler/frontend/ast_typ_uncurry.ml
@@ -23,20 +23,10 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
 type typ = Parsetree.core_type
-type 'a cxt = Ast_helper.loc -> Bs_ast_mapper.mapper -> 'a
-type uncurry_type_gen = (Asttypes.arg_label -> typ -> typ -> typ) cxt
 
-let to_method_callback_type loc (mapper : Bs_ast_mapper.mapper)
-    (label : Asttypes.arg_label) (first_arg : Parsetree.core_type)
-    (typ : Parsetree.core_type) =
-  let first_arg = mapper.typ mapper first_arg in
-  let typ = mapper.typ mapper typ in
-  let meth_type =
-    Ast_helper.Typ.arrow ~loc ~arity:None
-      {attrs = []; lbl = label; typ = first_arg}
-      typ
-  in
-  let arity = Ast_core_type.get_uncurry_arity meth_type in
+let to_method_callback_type loc (mapper : Bs_ast_mapper.mapper) ~arity
+    (meth_type : Parsetree.core_type) =
+  let meth_type = Bs_ast_mapper.default_mapper.typ mapper meth_type in
   match arity with
   | Some n ->
     Ast_helper.Typ.constr
@@ -46,30 +36,3 @@ let to_method_callback_type loc (mapper : Bs_ast_mapper.mapper)
       }
       [meth_type]
   | None -> assert false
-
-let to_uncurry_type loc (mapper : Bs_ast_mapper.mapper)
-    (label : Asttypes.arg_label) (first_arg : Parsetree.core_type)
-    (typ : Parsetree.core_type) =
-  (* no need to error for optional here,
-     since we can not make it
-     TODO: still error out for external?
-     Maybe no need to error on optional at all
-     it just does not make sense
-  *)
-  let first_arg = mapper.typ mapper first_arg in
-  let typ = mapper.typ mapper typ in
-
-  let fn_type =
-    Ast_helper.Typ.arrow ~loc ~arity:None
-      {attrs = []; lbl = label; typ = first_arg}
-      typ
-  in
-  let arity = Ast_core_type.get_uncurry_arity fn_type in
-  let fn_type =
-    match fn_type.ptyp_desc with
-    | Ptyp_arrow arr -> {fn_type with ptyp_desc = Ptyp_arrow {arr with arity}}
-    | _ -> assert false
-  in
-  match arity with
-  | Some arity -> Ast_uncurried.uncurried_type ~arity fn_type
-  | None -> assert false
diff --git a/compiler/frontend/ast_typ_uncurry.mli b/compiler/frontend/ast_typ_uncurry.mli
@@ -37,24 +37,14 @@
 
 type typ = Parsetree.core_type
 
-type 'a cxt = Ast_helper.loc -> Bs_ast_mapper.mapper -> 'a
-
-type uncurry_type_gen =
-  (Asttypes.arg_label ->
-  (* label for error checking *)
-  typ ->
-  (* First arg *)
+val to_method_callback_type :
+  Ast_helper.loc ->
+  Bs_ast_mapper.mapper ->
+  arity:int option ->
   typ ->
-  (* Tail *)
-  typ)
-  cxt
-
-val to_uncurry_type : uncurry_type_gen
-(** syntax : 
-    {[ int -> int -> int [@bs]]}
-*)
+  (* Method type *)
+  typ
 
-val to_method_callback_type : uncurry_type_gen
 (** syntax:
     {[ 'obj -> int -> int [@this] ]}
 *)
diff --git a/compiler/frontend/ast_uncurry_gen.ml b/compiler/frontend/ast_uncurry_gen.ml
@@ -48,6 +48,11 @@ let to_method_callback loc (self : Bs_ast_mapper.mapper) label
         Ast_helper.Exp.fun_ ~loc ~attrs ~arity:None ~async label None p e)
   in
   let arity = List.length rev_extra_args in
+  let body =
+    match body.pexp_desc with
+    | Pexp_fun f -> {body with pexp_desc = Pexp_fun {f with arity = Some arity}}
+    | _ -> body
+  in
   let arity_s = string_of_int arity in
   Stack.pop Js_config.self_stack |> ignore;
   Parsetree.Pexp_apply
