Refactor parse tree for function arguments.

cristianoc · cristianoc · commit 2b9722f92bce · 2025-07-15T10:29:50.000+02:00
Put the label and type together, so in future it will be possible to represent a function of several arguments with a list.
diff --git a/analysis/src/SignatureHelp.ml b/analysis/src/SignatureHelp.ml
@@ -112,9 +112,7 @@ let extractParameters ~signature ~typeStrForParser ~labelPrefixLen =
       match expr with
       | {
        (* Gotcha: functions with multiple arugments are modelled as a series of single argument functions. *)
-       Parsetree.ptyp_desc =
-         Ptyp_arrow
-           {lbl = argumentLabel; arg = argumentTypeExpr; ret = nextFunctionExpr};
+       Parsetree.ptyp_desc = Ptyp_arrow {arg; ret = nextFunctionExpr};
        ptyp_loc;
       } ->
         let startOffset =
@@ -123,20 +121,20 @@ let extractParameters ~signature ~typeStrForParser ~labelPrefixLen =
           |> Option.get
         in
         let endOffset =
-          argumentTypeExpr.ptyp_loc |> Loc.end_
+          arg.typ.ptyp_loc |> Loc.end_
           |> Pos.positionToOffset typeStrForParser
           |> Option.get
         in
         (* The AST locations does not account for "=?" of optional arguments, so add that to the offset here if needed. *)
         let endOffset =
-          match argumentLabel with
+          match arg.lbl with
           | Asttypes.Optional _ -> endOffset + 2
           | _ -> endOffset
         in
         extractParams nextFunctionExpr
           (params
           @ [
-              ( argumentLabel,
+              ( arg.lbl,
                 (* Remove the label prefix offset here, since we're not showing
                    that to the end user. *)
                 startOffset - labelPrefixLen,
diff --git a/compiler/frontend/ast_compatible.ml b/compiler/frontend/ast_compatible.ml
@@ -30,8 +30,8 @@ open Parsetree
 
 let default_loc = Location.none
 
-let arrow ?loc ?attrs ~arity a b =
-  Ast_helper.Typ.arrow ?loc ?attrs ~arity Nolabel a b
+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,22 +138,30 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn
         };
   }
 
-let label_arrow ?(loc = default_loc) ?(attrs = []) ~arity txt arg ret :
+let label_arrow ?(loc = default_loc) ?(attrs = []) ~arity txt typ ret :
     core_type =
   {
     ptyp_desc =
       Ptyp_arrow
-        {lbl = Asttypes.Labelled {txt; loc = default_loc}; arg; ret; arity};
+        {
+          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 arg ret : core_type
+let opt_arrow ?(loc = default_loc) ?(attrs = []) ~arity txt typ ret : core_type
     =
   {
     ptyp_desc =
       Ptyp_arrow
-        {lbl = Asttypes.Optional {txt; loc = default_loc}; arg; ret; arity};
+        {
+          arg = {lbl = Asttypes.Optional {txt; loc = default_loc}; typ};
+          ret;
+          arity;
+        };
     ptyp_loc = loc;
     ptyp_attributes = attrs;
   }
diff --git a/compiler/frontend/ast_core_type.ml b/compiler/frontend/ast_core_type.ml
@@ -142,7 +142,8 @@ let mk_fn_type (new_arg_types_ty : param_type list) (result : t) : t =
     Ext_list.fold_right new_arg_types_ty result
       (fun {label; ty; attr; loc} acc ->
         {
-          ptyp_desc = Ptyp_arrow {lbl = label; arg = ty; ret = acc; arity = None};
+          ptyp_desc =
+            Ptyp_arrow {arg = {lbl = label; typ = ty}; ret = acc; arity = None};
           ptyp_loc = loc;
           ptyp_attributes = attr;
         })
@@ -156,9 +157,14 @@ 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 {lbl = label; arg; ret; arity} when arity = None || acc = [] ->
+    | Ptyp_arrow {arg; ret; arity} when arity = None || acc = [] ->
       aux ret
-        (({label; ty = arg; attr = ty.ptyp_attributes; loc = ty.ptyp_loc}
+        (({
+            label = arg.lbl;
+            ty = arg.typ;
+            attr = ty.ptyp_attributes;
+            loc = ty.ptyp_loc;
+          }
            : param_type)
         :: acc)
     | Ptyp_poly (_, ty) ->
diff --git a/compiler/frontend/ast_core_type_class_type.ml b/compiler/frontend/ast_core_type_class_type.ml
@@ -67,17 +67,17 @@ 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 {lbl = label; arg = args; ret = body}
+  | Ptyp_arrow {arg; ret = body}
   (* 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 label args body
+      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 label args body
+      Ast_typ_uncurry.to_uncurry_type loc self arg.lbl arg.typ body
     | Nothing -> Bs_ast_mapper.default_mapper.typ self ty)
   | Ptyp_object (methods, closed_flag) ->
     let ( +> ) attr (typ : Parsetree.core_type) =
diff --git a/compiler/frontend/ast_exp_handle_external.ml b/compiler/frontend/ast_exp_handle_external.ml
@@ -44,7 +44,9 @@ 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) Nolabel (Typ.any ()) (Typ.any ()))
+            (Typ.arrow ~arity:(Some 1)
+               {lbl = Nolabel; typ = Typ.any ()}
+               (Typ.any ()))
           [str_exp];
     }
   in
@@ -70,7 +72,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) Nolabel (Typ.any ())
+        (Typ.arrow ~arity:(Some 1)
+           {lbl = Nolabel; typ = Typ.any ()}
            (Ast_literal.type_unit ()))
       [Ast_literal.val_unit ~loc ()]
   | _ ->
@@ -96,7 +99,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) Nolabel (Typ.any ()) (Typ.any ()))
+            (Typ.arrow ~arity:(Some 1)
+               {lbl = Nolabel; typ = Typ.any ()}
+               (Typ.any ()))
           [exp];
       pexp_attributes =
         (match !is_function with
@@ -123,11 +128,12 @@ let handle_ffi ~loc ~payload =
       let any = Ast_helper.Typ.any ~loc:e.pexp_loc () in
       let unit = Ast_literal.type_unit ~loc () in
       let rec arrow ~arity =
-        if arity = 0 then Ast_helper.Typ.arrow ~arity:None ~loc Nolabel unit any
+        if arity = 0 then
+          Ast_helper.Typ.arrow ~arity:None ~loc {lbl = Nolabel; typ = unit} any
         else if arity = 1 then
-          Ast_helper.Typ.arrow ~arity:None ~loc Nolabel any any
+          Ast_helper.Typ.arrow ~arity:None ~loc {lbl = Nolabel; typ = any} any
         else
-          Ast_helper.Typ.arrow ~loc ~arity:None Nolabel any
+          Ast_helper.Typ.arrow ~loc ~arity:None {lbl = Nolabel; typ = any}
             (arrow ~arity:(arity - 1))
       in
       match !is_function with
@@ -146,7 +152,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) Nolabel (Typ.any ()) (Typ.any ()))
+              (Typ.arrow ~arity:(Some 1)
+                 {lbl = Nolabel; typ = Typ.any ()}
+                 (Typ.any ()))
             [exp];
         pexp_attributes =
           (match !is_function with
@@ -163,7 +171,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) Nolabel (Typ.any ()) (Typ.any ()))
+              (Typ.arrow ~arity:(Some 1)
+                 {lbl = Nolabel; typ = Typ.any ()}
+                 (Typ.any ()))
             [exp];
       }
   | None ->
diff --git a/compiler/frontend/ast_typ_uncurry.ml b/compiler/frontend/ast_typ_uncurry.ml
@@ -33,7 +33,9 @@ let to_method_callback_type loc (mapper : Bs_ast_mapper.mapper)
     (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 label first_arg typ in
+  let meth_type =
+    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 ->
@@ -57,7 +59,7 @@ 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 label first_arg typ in
+  let fn_type = 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
@@ -100,8 +100,10 @@ module T = struct
     match desc with
     | Ptyp_any -> any ~loc ~attrs ()
     | Ptyp_var s -> var ~loc ~attrs s
-    | Ptyp_arrow {lbl; arg; ret; arity} ->
-      arrow ~loc ~attrs ~arity lbl (sub.typ sub arg) (sub.typ sub ret)
+    | Ptyp_arrow {arg; ret; arity} ->
+      arrow ~loc ~attrs ~arity
+        {arg with typ = sub.typ sub arg.typ}
+        (sub.typ sub ret)
     | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
     | Ptyp_constr (lid, tl) ->
       constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
@@ -151,7 +153,7 @@ module T = struct
     | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l)
     | Ptype_open -> Ptype_open
 
-  let map_constructor_arguments sub = function
+  let map_constructor_arguments (sub : mapper) = function
     | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l)
     | Pcstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l)
 
diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml
@@ -54,8 +54,8 @@ module Typ = struct
 
   let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any
   let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a)
-  let arrow ?loc ?attrs ~arity lbl arg ret =
-    mk ?loc ?attrs (Ptyp_arrow {lbl; arg; ret; arity})
+  let arrow ?loc ?attrs ~arity arg ret =
+    mk ?loc ?attrs (Ptyp_arrow {arg; ret; arity})
   let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a)
   let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b))
   let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b))
@@ -83,7 +83,8 @@ module Typ = struct
           check_variable var_names t.ptyp_loc x;
           Ptyp_var x
         | Ptyp_arrow ({arg; ret} as arr) ->
-          Ptyp_arrow {arr with arg = loop arg; ret = loop ret}
+          Ptyp_arrow
+            {arr with arg = {arr.arg with typ = loop arg.typ}; ret = loop ret}
         | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
         | Ptyp_constr ({txt = Longident.Lident s}, []) when List.mem s var_names
           ->
diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli
@@ -55,13 +55,7 @@ module Typ : sig
   val any : ?loc:loc -> ?attrs:attrs -> unit -> core_type
   val var : ?loc:loc -> ?attrs:attrs -> string -> core_type
   val arrow :
-    ?loc:loc ->
-    ?attrs:attrs ->
-    arity:arity ->
-    arg_label ->
-    core_type ->
-    core_type ->
-    core_type
+    ?loc:loc -> ?attrs:attrs -> arity:arity -> arg -> core_type -> core_type
   val tuple : ?loc:loc -> ?attrs:attrs -> core_type list -> core_type
   val constr : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
   val object_ :
diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml
@@ -97,7 +97,7 @@ module T = struct
     match desc with
     | Ptyp_any | Ptyp_var _ -> ()
     | Ptyp_arrow {arg; ret} ->
-      sub.typ sub arg;
+      sub.typ sub arg.typ;
       sub.typ sub ret
     | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl
     | Ptyp_constr (lid, tl) ->
diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml
@@ -92,8 +92,10 @@ module T = struct
     match desc with
     | Ptyp_any -> any ~loc ~attrs ()
     | Ptyp_var s -> var ~loc ~attrs s
-    | Ptyp_arrow {lbl; arg; ret; arity} ->
-      arrow ~loc ~attrs ~arity lbl (sub.typ sub arg) (sub.typ sub ret)
+    | Ptyp_arrow {arg; ret; arity} ->
+      arrow ~loc ~attrs ~arity
+        {arg with typ = sub.typ sub arg.typ}
+        (sub.typ sub ret)
     | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
     | Ptyp_constr (lid, tl) ->
       constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml
@@ -98,9 +98,9 @@ module T = struct
     match desc with
     | Ptyp_any -> any ~loc ~attrs ()
     | Ptyp_var s -> var ~loc ~attrs s
-    | Ptyp_arrow (lab, t1, t2) ->
-      let lab = Asttypes.to_arg_label lab in
-      arrow ~loc ~attrs ~arity:None lab (sub.typ sub t1) (sub.typ sub t2)
+    | Ptyp_arrow (lbl, t1, t2) ->
+      let lbl = Asttypes.to_arg_label lbl in
+      arrow ~loc ~attrs ~arity:None {lbl; typ = sub.typ sub t1} (sub.typ sub t2)
     | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
     | Ptyp_constr (lid, tl) -> (
       let typ0 =
diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml
@@ -98,9 +98,11 @@ module T = struct
     match desc with
     | Ptyp_any -> any ~loc ~attrs ()
     | Ptyp_var s -> var ~loc ~attrs s
-    | Ptyp_arrow {lbl; arg; ret; arity} -> (
-      let lbl = Asttypes.to_noloc lbl in
-      let typ0 = arrow ~loc ~attrs lbl (sub.typ sub arg) (sub.typ sub ret) in
+    | Ptyp_arrow {arg; ret; arity} -> (
+      let lbl = Asttypes.to_noloc arg.lbl in
+      let typ0 =
+        arrow ~loc ~attrs lbl (sub.typ sub arg.typ) (sub.typ sub ret)
+      in
       match arity with
       | None -> typ0
       | Some arity ->
diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml
@@ -106,7 +106,7 @@ let rec add_type bv ty =
   | Ptyp_any -> ()
   | Ptyp_var _ -> ()
   | Ptyp_arrow {arg; ret} ->
-    add_type bv arg;
+    add_type bv arg.typ;
     add_type bv ret
   | Ptyp_tuple tl -> List.iter (add_type bv) tl
   | Ptyp_constr (c, tl) ->
diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml
@@ -73,10 +73,12 @@ and core_type = {
   ptyp_attributes: attributes; (* ... [@id1] [@id2] *)
 }
 
+and arg = {lbl: arg_label; typ: core_type}
+
 and core_type_desc =
   | Ptyp_any (*  _ *)
   | Ptyp_var of string (* 'a *)
-  | Ptyp_arrow of {lbl: arg_label; arg: core_type; ret: core_type; arity: arity}
+  | Ptyp_arrow of {arg: arg; ret: core_type; arity: arity}
     (* T1 -> T2       Simple
        ~l:T1 -> T2    Labelled
        ?l:T1 -> T2    Optional
diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml
@@ -298,9 +298,9 @@ and core_type ctxt f x =
       (attributes ctxt) x.ptyp_attributes
   else
     match x.ptyp_desc with
-    | Ptyp_arrow {lbl = l; arg; ret; arity} ->
+    | Ptyp_arrow {arg; ret; arity} ->
       pp f "@[<2>%a@;->@;%a%s@]" (* FIXME remove parens later *)
-        (type_with_label ctxt) (l, arg) (core_type ctxt) ret
+        (type_with_label ctxt) (arg.lbl, arg.typ) (core_type ctxt) ret
         (match arity with
         | None -> ""
         | Some n -> " (a:" ^ string_of_int n ^ ")")
diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml
@@ -123,15 +123,15 @@ let rec core_type i ppf x =
   match x.ptyp_desc with
   | Ptyp_any -> line i ppf "Ptyp_any\n"
   | Ptyp_var s -> line i ppf "Ptyp_var %s\n" s
-  | Ptyp_arrow {lbl; arg; ret; arity} ->
+  | Ptyp_arrow {arg; ret; arity} ->
     line i ppf "Ptyp_arrow\n";
     let () =
       match arity with
       | None -> ()
       | Some n -> line i ppf "arity = %d\n" n
     in
-    arg_label_loc i ppf lbl;
-    core_type i ppf arg;
+    arg_label_loc i ppf arg.lbl;
+    core_type i ppf arg.typ;
     core_type i ppf ret
   | Ptyp_tuple l ->
     line i ppf "Ptyp_tuple\n";
diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml
@@ -1871,7 +1871,7 @@ and is_nonexpansive_opt = function
 
 let rec approx_type env sty =
   match sty.ptyp_desc with
-  | Ptyp_arrow {lbl = p; ret = sty; arity} ->
+  | Ptyp_arrow {arg = {lbl = p}; ret = sty; arity} ->
     let p = Asttypes.to_noloc p in
     let ty1 = if is_optional p then type_option (newvar ()) else newvar () in
     newty (Tarrow (p, ty1, approx_type env sty, Cok, arity))
diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml
diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml
diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml
diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml
diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml
diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml
