Refactor: construct every Ptyp_arrow via Ast_helper.Typ.arrow.

cristianoc · cristianoc · commit bf020e9bdcce · 2025-07-17T08:29:29.000+02:00
This should give an explicit handle over how all arrow types are constructed.
diff --git a/compiler/frontend/ast_comb.ml b/compiler/frontend/ast_comb.ml
@@ -33,30 +33,6 @@ open Ast_helper
     [Exp.constraint_ ~loc e
        (Ast_literal.type_unit ~loc ())] *)
 
-let tuple_type_pair ?loc kind arity =
-  let prefix = "a" in
-  if arity = 0 then
-    let ty = Typ.var ?loc (prefix ^ "0") in
-    match kind with
-    | `Run -> (ty, [], ty)
-    | `Make ->
-      ( Ast_compatible.arrow ?loc ~arity:None (Ast_literal.type_unit ?loc ()) ty,
-        [],
-        ty )
-  else
-    let number = arity + 1 in
-    let tys =
-      Ext_list.init number (fun i ->
-          Typ.var ?loc (prefix ^ string_of_int (number - i - 1)))
-    in
-    match tys with
-    | result :: rest ->
-      ( Ext_list.reduce_from_left tys (fun r arg ->
-            Ast_compatible.arrow ?loc ~arity:None arg r),
-        List.rev rest,
-        result )
-    | [] -> assert false
-
 let regexp_id = Ast_literal.Lid.regexp_id
 
 let to_regexp_type loc = Typ.constr ~loc {txt = regexp_id; loc} []
diff --git a/compiler/frontend/ast_comb.mli b/compiler/frontend/ast_comb.mli
@@ -31,12 +31,6 @@
 (* val discard_exp_as_unit :
    Location.t -> Parsetree.expression -> Parsetree.expression *)
 
-val tuple_type_pair :
-  ?loc:Ast_helper.loc ->
-  [< `Make | `Run] ->
-  int ->
-  Parsetree.core_type * Parsetree.core_type list * Parsetree.core_type
-
 val to_undefined_type : Location.t -> Parsetree.core_type -> Parsetree.core_type
 
 val to_regexp_type : Location.t -> Parsetree.core_type
diff --git a/compiler/frontend/ast_compatible.ml b/compiler/frontend/ast_compatible.ml
@@ -30,9 +30,6 @@ open Parsetree
 
 let default_loc = Location.none
 
-let arrow ?loc ?attrs ~arity typ ret =
-  Ast_helper.Typ.arrow ?loc ?attrs ~arity {lbl = Nolabel; typ} ret
-
 let apply_simple ?(loc = default_loc) ?(attrs = []) (fn : expression)
     (args : expression list) : expression =
   {
@@ -138,34 +135,6 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn
         };
   }
 
-let label_arrow ?(loc = default_loc) ?(attrs = []) ~arity txt typ ret :
-    core_type =
-  {
-    ptyp_desc =
-      Ptyp_arrow
-        {
-          arg = {lbl = Asttypes.Labelled {txt; loc = default_loc}; typ};
-          ret;
-          arity;
-        };
-    ptyp_loc = loc;
-    ptyp_attributes = attrs;
-  }
-
-let opt_arrow ?(loc = default_loc) ?(attrs = []) ~arity txt typ ret : core_type
-    =
-  {
-    ptyp_desc =
-      Ptyp_arrow
-        {
-          arg = {lbl = Asttypes.Optional {txt; loc = default_loc}; typ};
-          ret;
-          arity;
-        };
-    ptyp_loc = loc;
-    ptyp_attributes = attrs;
-  }
-
 let rec_type_str ?(loc = default_loc) rf tds : structure_item =
   {pstr_loc = loc; pstr_desc = Pstr_type (rf, tds)}
 
diff --git a/compiler/frontend/ast_compatible.mli b/compiler/frontend/ast_compatible.mli
@@ -90,32 +90,6 @@ val fun_ :
    expression ->
    expression *)
 
-val arrow :
-  ?loc:Location.t ->
-  ?attrs:attrs ->
-  arity:Asttypes.arity ->
-  core_type ->
-  core_type ->
-  core_type
-
-val label_arrow :
-  ?loc:Location.t ->
-  ?attrs:attrs ->
-  arity:Asttypes.arity ->
-  string ->
-  core_type ->
-  core_type ->
-  core_type
-
-val opt_arrow :
-  ?loc:Location.t ->
-  ?attrs:attrs ->
-  arity:Asttypes.arity ->
-  string ->
-  core_type ->
-  core_type ->
-  core_type
-
 (* val nonrec_type_str:
    ?loc:loc ->
    type_declaration list ->
diff --git a/compiler/frontend/ast_core_type.ml b/compiler/frontend/ast_core_type.ml
@@ -95,8 +95,9 @@ let from_labels ~loc arity labels : t =
   in
   Ext_list.fold_right2 labels tyvars result_type
     (fun label (* {loc ; txt = label }*) tyvar acc ->
-      Ast_compatible.label_arrow ~loc:label.loc ~arity:(Some arity) label.txt
-        tyvar acc)
+      Ast_helper.Typ.arrow ~loc:label.loc ~arity:(Some arity)
+        {lbl = Asttypes.Labelled label; typ = tyvar}
+        acc)
 
 let make_obj ~loc xs = Typ.object_ ~loc xs Closed
 
@@ -141,12 +142,8 @@ let mk_fn_type (new_arg_types_ty : param_type list) (result : t) : t =
   let t =
     Ext_list.fold_right new_arg_types_ty result
       (fun {label; ty; attr; loc} acc ->
-        {
-          ptyp_desc =
-            Ptyp_arrow {arg = {lbl = label; typ = ty}; ret = acc; arity = None};
-          ptyp_loc = loc;
-          ptyp_attributes = attr;
-        })
+        Ast_helper.Typ.arrow ~loc ~attrs:attr ~arity:None
+          {lbl = label; typ = ty} acc)
   in
   match t.ptyp_desc with
   | Ptyp_arrow arr ->
diff --git a/compiler/frontend/ast_derive_abstract.ml b/compiler/frontend/ast_derive_abstract.ml
@@ -83,7 +83,8 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
       Ext_list.fold_right label_declarations
         ( [],
           (if has_optional_field then
-             Ast_compatible.arrow ~loc ~arity:None (Ast_literal.type_unit ())
+             Ast_helper.Typ.arrow ~loc ~arity:None
+               {lbl = Nolabel; typ = Ast_literal.type_unit ()}
                core_type
            else core_type),
           [] )
@@ -114,18 +115,21 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
             in
             if is_optional then
               let optional_type = Ast_core_type.lift_option_type pld_type in
-              ( Ast_compatible.opt_arrow ~loc:pld_loc ~arity label_name pld_type
+              ( Ast_helper.Typ.arrow ~loc:pld_loc ~arity
+                  {lbl = Asttypes.Optional pld_name; typ = pld_type}
                   maker,
                 Val.mk ~loc:pld_loc
                   (if light then pld_name
                    else {pld_name with txt = pld_name.txt ^ "Get"})
                   ~attrs:get_optional_attrs ~prim
-                  (Ast_compatible.arrow ~loc ~arity:(Some 1) core_type
+                  (Ast_helper.Typ.arrow ~loc ~arity:(Some 1)
+                     {lbl = Nolabel; typ = core_type}
                      optional_type)
                 :: acc )
             else
-              ( Ast_compatible.label_arrow ~loc:pld_loc ~arity label_name
-                  pld_type maker,
+              ( Ast_helper.Typ.arrow ~loc:pld_loc ~arity
+                  {lbl = Asttypes.Labelled pld_name; typ = pld_type}
+                  maker,
                 Val.mk ~loc:pld_loc
                   (if light then pld_name
                    else {pld_name with txt = pld_name.txt ^ "Get"})
@@ -135,15 +139,19 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
                      External_ffi_types.ffi_bs_as_prims
                        [External_arg_spec.dummy] Return_identity
                        (Js_get {js_get_name = prim_as_name; js_get_scopes = []}))
-                  (Ast_compatible.arrow ~loc ~arity:(Some 1) core_type pld_type)
+                  (Ast_helper.Typ.arrow ~loc ~arity:(Some 1)
+                     {lbl = Nolabel; typ = core_type}
+                     pld_type)
                 :: acc )
           in
           let is_current_field_mutable = pld_mutable = Mutable in
           let acc =
             if is_current_field_mutable then
               let setter_type =
-                Ast_compatible.arrow ~arity:(Some 2) core_type
-                  (Ast_compatible.arrow ~arity:None pld_type (* setter *)
+                Ast_helper.Typ.arrow ~arity:(Some 2)
+                  {lbl = Nolabel; typ = core_type}
+                  (Ast_helper.Typ.arrow ~arity:None
+                     {lbl = Nolabel; typ = pld_type} (* setter *)
                      (Ast_literal.type_unit ()))
               in
               Val.mk ~loc:pld_loc
diff --git a/compiler/frontend/ast_derive_js_mapper.ml b/compiler/frontend/ast_derive_js_mapper.ml
@@ -69,7 +69,7 @@ let erase_type_str =
   Str.primitive
     (Val.mk ~prim:["%identity"]
        {loc = noloc; txt = erase_type_lit}
-       (Ast_compatible.arrow ~arity:(Some 1) any any))
+       (Ast_helper.Typ.arrow ~arity:(Some 1) {lbl = Nolabel; typ = any} any))
 
 let unsafe_index = "_index"
 
@@ -79,8 +79,8 @@ let unsafe_index_get =
     (Val.mk ~prim:[""]
        {loc = noloc; txt = unsafe_index}
        ~attrs:[Ast_attributes.get_index]
-       (Ast_compatible.arrow ~arity:None any
-          (Ast_compatible.arrow ~arity:None any any)))
+       (Ast_helper.Typ.arrow ~arity:None {lbl = Nolabel; typ = any}
+          (Ast_helper.Typ.arrow ~arity:None {lbl = Nolabel; typ = any} any)))
 
 let unsafe_index_get_exp = Exp.ident {loc = noloc; txt = Lident unsafe_index}
 
@@ -131,7 +131,8 @@ let app1 = Ast_compatible.app1
 
 let app2 = Ast_compatible.app2
 
-let ( ->~ ) a b = Ast_compatible.arrow ~arity:(Some 1) a b
+let ( ->~ ) a b =
+  Ast_helper.Typ.arrow ~arity:(Some 1) {lbl = Nolabel; typ = a} b
 
 let raise_when_not_found_ident =
   Longident.Ldot (Lident Primitive_modules.util, "raiseWhenNotFound")
@@ -303,7 +304,9 @@ 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_compatible.arrow ~arity:(Some 1) core_type result)
+                  (Ast_helper.Typ.arrow ~arity:(Some 1)
+                     {lbl = Nolabel; typ = core_type}
+                     result)
               in
               let new_type, new_tdcl =
                 U.new_type_of_type_declaration tdcl ("abs_" ^ name)
diff --git a/compiler/frontend/ast_derive_projector.ml b/compiler/frontend/ast_derive_projector.ml
@@ -136,7 +136,8 @@ let init () =
               | Ptype_record label_declarations ->
                 Ext_list.map label_declarations (fun {pld_name; pld_type} ->
                     Ast_comb.single_non_rec_val ?attrs:gentype_attrs pld_name
-                      (Ast_compatible.arrow ~arity:(Some 1) core_type
+                      (Ast_helper.Typ.arrow ~arity:(Some 1)
+                         {lbl = Nolabel; typ = core_type}
                          pld_type
                          (*arity will alwys be 1 since these are single param functions*)))
               | Ptype_variant constructor_declarations ->
@@ -168,7 +169,8 @@ let init () =
                     Ast_comb.single_non_rec_val ?attrs:gentype_attrs
                       {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)
+                           Ast_helper.Typ.arrow ~arity:None
+                             {lbl = Nolabel; typ = x} acc)
                       |> add_arity ~arity))
               | Ptype_open | Ptype_abstract ->
                 Ast_derive_util.not_applicable tdcl.ptype_loc deriving_name;
diff --git a/compiler/frontend/ast_exp_handle_external.ml b/compiler/frontend/ast_exp_handle_external.ml
@@ -22,8 +22,6 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
-open Ast_helper
-
 (**
    {[
      Js.undefinedToOption 
@@ -44,25 +42,26 @@ let handle_external loc (x : string) : Parsetree.expression =
       pexp_desc =
         Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
           ~pval_type:
-            (Typ.arrow ~arity:(Some 1)
-               {lbl = Nolabel; typ = Typ.any ()}
-               (Typ.any ()))
+            (Ast_helper.Typ.arrow ~arity:(Some 1)
+               {lbl = Nolabel; typ = Ast_helper.Typ.any ()}
+               (Ast_helper.Typ.any ()))
           [str_exp];
     }
   in
   let empty =
     (* FIXME: the empty delimiter does not make sense*)
-    Exp.ident ~loc {txt = Ldot (Ldot (Lident "Js", "Undefined"), "empty"); loc}
+    Ast_helper.Exp.ident ~loc
+      {txt = Ldot (Ldot (Lident "Js", "Undefined"), "empty"); loc}
   in
   let undefined_typeof =
-    Exp.ident {loc; txt = Ldot (Lident "Js", "undefinedToOption")}
+    Ast_helper.Exp.ident {loc; txt = Ldot (Lident "Js", "undefinedToOption")}
   in
-  let typeof = Exp.ident {loc; txt = Ldot (Lident "Js", "typeof")} in
+  let typeof = Ast_helper.Exp.ident {loc; txt = Ldot (Lident "Js", "typeof")} in
 
   Ast_compatible.app1 ~loc undefined_typeof
-    (Exp.ifthenelse ~loc
+    (Ast_helper.Exp.ifthenelse ~loc
        (Ast_compatible.app2 ~loc
-          (Exp.ident ~loc {loc; txt = Lident "=="})
+          (Ast_helper.Exp.ident ~loc {loc; txt = Lident "=="})
           (Ast_compatible.app1 ~loc typeof raw_exp)
           (Ast_compatible.const_exp_string ~loc "undefined"))
        empty (Some raw_exp))
@@ -72,8 +71,8 @@ let handle_debugger loc (payload : Ast_payload.t) =
   | PStr [] ->
     Ast_external_mk.local_external_apply loc ~pval_prim:["%debugger"]
       ~pval_type:
-        (Typ.arrow ~arity:(Some 1)
-           {lbl = Nolabel; typ = Typ.any ()}
+        (Ast_helper.Typ.arrow ~arity:(Some 1)
+           {lbl = Nolabel; typ = Ast_helper.Typ.any ()}
            (Ast_literal.type_unit ()))
       [Ast_literal.val_unit ~loc ()]
   | _ ->
@@ -99,9 +98,9 @@ let handle_raw ~kind loc payload =
       pexp_desc =
         Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
           ~pval_type:
-            (Typ.arrow ~arity:(Some 1)
-               {lbl = Nolabel; typ = Typ.any ()}
-               (Typ.any ()))
+            (Ast_helper.Typ.arrow ~arity:(Some 1)
+               {lbl = Nolabel; typ = Ast_helper.Typ.any ()}
+               (Ast_helper.Typ.any ()))
           [exp];
       pexp_attributes =
         (match !is_function with
@@ -152,9 +151,9 @@ let handle_ffi ~loc ~payload =
         pexp_desc =
           Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
             ~pval_type:
-              (Typ.arrow ~arity:(Some 1)
-                 {lbl = Nolabel; typ = Typ.any ()}
-                 (Typ.any ()))
+              (Ast_helper.Typ.arrow ~arity:(Some 1)
+                 {lbl = Nolabel; typ = Ast_helper.Typ.any ()}
+                 (Ast_helper.Typ.any ()))
             [exp];
         pexp_attributes =
           (match !is_function with
@@ -171,9 +170,9 @@ let handle_raw_structure loc payload =
         pexp_desc =
           Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_stmt"]
             ~pval_type:
-              (Typ.arrow ~arity:(Some 1)
-                 {lbl = Nolabel; typ = Typ.any ()}
-                 (Typ.any ()))
+              (Ast_helper.Typ.arrow ~arity:(Some 1)
+                 {lbl = Nolabel; typ = Ast_helper.Typ.any ()}
+                 (Ast_helper.Typ.any ()))
             [exp];
       }
   | None ->
diff --git a/compiler/frontend/ast_typ_uncurry.ml b/compiler/frontend/ast_typ_uncurry.ml
@@ -26,20 +26,18 @@ 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
 
-module Typ = Ast_helper.Typ
-
 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 =
-    Typ.arrow ~loc ~arity:None {lbl = label; typ = first_arg} typ
+    Ast_helper.Typ.arrow ~loc ~arity:None {lbl = label; typ = first_arg} typ
   in
   let arity = Ast_core_type.get_uncurry_arity meth_type in
   match arity with
   | Some n ->
-    Typ.constr
+    Ast_helper.Typ.constr
       {
         txt = Ldot (Ast_literal.Lid.js_meth_callback, "arity" ^ string_of_int n);
         loc;
@@ -59,7 +57,9 @@ let to_uncurry_type loc (mapper : Bs_ast_mapper.mapper)
   let first_arg = mapper.typ mapper first_arg in
   let typ = mapper.typ mapper typ in
 
-  let fn_type = Typ.arrow ~loc ~arity:None {lbl = label; typ = first_arg} typ in
+  let fn_type =
+    Ast_helper.Typ.arrow ~loc ~arity:None {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
diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml
diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml
diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml
