Store location directly in the label on Ptyp_arrow instead of a separate field.

cristianoc · cristianoc · commit 1b8353879d1c · 2025-01-30T14:28:13.000+01:00
diff --git a/analysis/src/SignatureHelp.ml b/analysis/src/SignatureHelp.ml
@@ -130,7 +130,7 @@ let extractParameters ~signature ~typeStrForParser ~labelPrefixLen =
         (* The AST locations does not account for "=?" of optional arguments, so add that to the offset here if needed. *)
         let endOffset =
           match argumentLabel with
-          | Asttypes.Optional _ -> endOffset + 2
+          | Asttypes.Opt _ -> endOffset + 2
           | _ -> endOffset
         in
         extractParams nextFunctionExpr
@@ -474,6 +474,7 @@ let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads =
                     parameters =
                       parameters
                       |> List.map (fun (argLabel, start, end_) ->
+                             let argLabel = Asttypes.to_arg_label argLabel in
                              let paramArgCount = !paramUnlabelledArgCount in
                              paramUnlabelledArgCount := paramArgCount + 1;
                              let unlabelledArgCount = ref 0 in
diff --git a/compiler/frontend/ast_compatible.ml b/compiler/frontend/ast_compatible.ml
@@ -31,7 +31,7 @@ open Parsetree
 let default_loc = Location.none
 
 let arrow ?loc ?attrs ~arity a b =
-  Ast_helper.Typ.arrow ?loc ?attrs ~arity Nolabel a b
+  Ast_helper.Typ.arrow ?loc ?attrs ~arity Nolbl a b
 
 let apply_simple ?(loc = default_loc) ?(attrs = []) (fn : expression)
     (args : expression list) : expression =
@@ -124,20 +124,20 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn
         };
   }
 
-let label_arrow ?(loc = default_loc) ?(attrs = []) ~arity s arg ret : core_type
-    =
+let label_arrow ?(loc = default_loc) ?(attrs = []) ~arity txt arg ret :
+    core_type =
   {
     ptyp_desc =
-      Ptyp_arrow {lbl = Labelled s; lbl_loc = Location.none; arg; ret; arity};
+      Ptyp_arrow {lbl = Asttypes.Lbl {txt; loc = default_loc}; arg; ret; arity};
     ptyp_loc = loc;
     ptyp_attributes = attrs;
   }
 
-let opt_arrow ?(loc = default_loc) ?(attrs = []) ~arity s arg ret : core_type =
+let opt_arrow ?(loc = default_loc) ?(attrs = []) ~arity txt arg ret : core_type
+    =
   {
     ptyp_desc =
-      Ptyp_arrow
-        {lbl = Asttypes.Optional s; lbl_loc = Location.none; arg; ret; arity};
+      Ptyp_arrow {lbl = Asttypes.Opt {txt; loc = default_loc}; arg; ret; arity};
     ptyp_loc = loc;
     ptyp_attributes = attrs;
   }
diff --git a/compiler/frontend/ast_core_type.ml b/compiler/frontend/ast_core_type.ml
@@ -131,7 +131,7 @@ let get_curry_arity (ty : t) =
 let is_arity_one ty = get_curry_arity ty = 1
 
 type param_type = {
-  label: Asttypes.arg_label;
+  label: Asttypes.arg_label_loc;
   ty: Parsetree.core_type;
   attr: Parsetree.attributes;
   loc: loc;
@@ -142,15 +142,7 @@ 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;
-                lbl_loc = Location.none;
-                arg = ty;
-                ret = acc;
-                arity = None;
-              };
+          ptyp_desc = Ptyp_arrow {lbl = label; arg = ty; ret = acc; arity = None};
           ptyp_loc = loc;
           ptyp_attributes = attr;
         })
@@ -179,5 +171,5 @@ let list_of_arrow (ty : t) : t * param_type list =
 let add_last_obj (ty : t) (obj : t) =
   let result, params = list_of_arrow ty in
   mk_fn_type
-    (params @ [{label = Nolabel; ty = obj; attr = []; loc = obj.ptyp_loc}])
+    (params @ [{label = Nolbl; ty = obj; attr = []; loc = obj.ptyp_loc}])
     result
diff --git a/compiler/frontend/ast_core_type.mli b/compiler/frontend/ast_core_type.mli
@@ -48,7 +48,7 @@ val get_uncurry_arity : t -> int option
 *)
 
 type param_type = {
-  label: Asttypes.arg_label;
+  label: Asttypes.arg_label_loc;
   ty: t;
   attr: Parsetree.attributes;
   loc: Location.t;
diff --git a/compiler/frontend/ast_core_type_class_type.ml b/compiler/frontend/ast_core_type_class_type.ml
@@ -106,7 +106,7 @@ 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_typ_uncurry.to_uncurry_type loc self Nolbl core_type
                    (Ast_literal.type_unit ~loc ()))
             in
             let not_getter_setter ty =
diff --git a/compiler/frontend/ast_exp_handle_external.ml b/compiler/frontend/ast_exp_handle_external.ml
@@ -43,8 +43,7 @@ let handle_external loc (x : string) : Parsetree.expression =
       str_exp with
       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 ()))
+          ~pval_type:(Typ.arrow ~arity:(Some 1) Nolbl (Typ.any ()) (Typ.any ()))
           [str_exp];
     }
   in
@@ -70,8 +69,7 @@ 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 ())
-           (Ast_literal.type_unit ()))
+        (Typ.arrow ~arity:(Some 1) Nolbl (Typ.any ()) (Ast_literal.type_unit ()))
       [Ast_literal.val_unit ~loc ()]
   | _ ->
     Location.raise_errorf ~loc "%%debugger extension doesn't accept arguments"
@@ -95,8 +93,7 @@ let handle_raw ~kind loc payload =
       exp with
       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 ()))
+          ~pval_type:(Typ.arrow ~arity:(Some 1) Nolbl (Typ.any ()) (Typ.any ()))
           [exp];
       pexp_attributes =
         (match !is_function with
@@ -123,11 +120,11 @@ 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 Nolbl unit any
         else if arity = 1 then
-          Ast_helper.Typ.arrow ~arity:None ~loc Nolabel any any
+          Ast_helper.Typ.arrow ~arity:None ~loc Nolbl any any
         else
-          Ast_helper.Typ.arrow ~loc ~arity:None Nolabel any
+          Ast_helper.Typ.arrow ~loc ~arity:None Nolbl any
             (arrow ~arity:(arity - 1))
       in
       match !is_function with
@@ -146,7 +143,7 @@ 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) Nolbl (Typ.any ()) (Typ.any ()))
             [exp];
         pexp_attributes =
           (match !is_function with
@@ -163,7 +160,7 @@ 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) Nolbl (Typ.any ()) (Typ.any ()))
             [exp];
       }
   | None ->
diff --git a/compiler/frontend/ast_external_process.ml b/compiler/frontend/ast_external_process.ml
@@ -462,7 +462,7 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
           let ty = param_type.ty in
           let new_arg_label, new_arg_types, output_tys =
             match arg_label with
-            | Nolabel -> (
+            | Nolbl -> (
               match ty.ptyp_desc with
               | Ptyp_constr ({txt = Lident "unit"}, []) ->
                 ( External_arg_spec.empty_kind Extern_unit,
@@ -471,7 +471,7 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
               | _ ->
                 Location.raise_errorf ~loc
                   "expect label, optional, or unit here")
-            | Labelled label -> (
+            | Lbl {txt = label} -> (
               let field_name =
                 match
                   Ast_attributes.iter_process_bs_string_as param_type.attr
@@ -530,7 +530,7 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
               | Unwrap ->
                 Location.raise_errorf ~loc
                   "%@obj label %s does not support %@unwrap arguments" label)
-            | Optional label -> (
+            | Opt {txt = label} -> (
               let field_name =
                 match
                   Ast_attributes.iter_process_bs_string_as param_type.attr
@@ -964,10 +964,10 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
           let ty = param_type.ty in
           (if i = 0 && splice then
              match arg_label with
-             | Optional _ ->
+             | Opt _ ->
                Location.raise_errorf ~loc
                  "%@variadic expect the last type to be a non optional"
-             | Labelled _ | Nolabel -> (
+             | Lbl _ | Nolbl -> (
                if ty.ptyp_desc = Ptyp_any then
                  Location.raise_errorf ~loc
                    "%@variadic expect the last type to be an array";
@@ -983,7 +983,7 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
                 arg_type,
                 new_arg_types ) =
             match arg_label with
-            | Optional s -> (
+            | Opt {txt = s} -> (
               let arg_type = get_opt_arg_type ~nolabel:false ty in
               match arg_type with
               | Poly_var _ ->
@@ -993,14 +993,14 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
                    label %s"
                   s
               | _ -> (Arg_optional, arg_type, param_type :: arg_types))
-            | Labelled _ -> (
+            | Lbl _ -> (
               let arg_type = refine_arg_type ~nolabel:false ty in
               ( Arg_label,
                 arg_type,
                 match arg_type with
                 | Arg_cst _ -> arg_types
                 | _ -> param_type :: arg_types ))
-            | Nolabel -> (
+            | Nolbl -> (
               let arg_type = refine_arg_type ~nolabel:true ty in
               ( Arg_empty,
                 arg_type,
diff --git a/compiler/frontend/ast_typ_uncurry.ml b/compiler/frontend/ast_typ_uncurry.ml
@@ -24,12 +24,12 @@
 
 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
+type uncurry_type_gen = (Asttypes.arg_label_loc -> 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)
+    (label : Asttypes.arg_label_loc) (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
@@ -46,7 +46,7 @@ let to_method_callback_type loc (mapper : Bs_ast_mapper.mapper)
   | None -> assert false
 
 let to_uncurry_type loc (mapper : Bs_ast_mapper.mapper)
-    (label : Asttypes.arg_label) (first_arg : Parsetree.core_type)
+    (label : Asttypes.arg_label_loc) (first_arg : Parsetree.core_type)
     (typ : Parsetree.core_type) =
   (* no need to error for optional here,
      since we can not make it
diff --git a/compiler/frontend/ast_typ_uncurry.mli b/compiler/frontend/ast_typ_uncurry.mli
@@ -40,7 +40,7 @@ type typ = Parsetree.core_type
 type 'a cxt = Ast_helper.loc -> Bs_ast_mapper.mapper -> 'a
 
 type uncurry_type_gen =
-  (Asttypes.arg_label ->
+  (Asttypes.arg_label_loc ->
   (* label for error checking *)
   typ ->
   (* First arg *)
diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml
@@ -101,9 +101,8 @@ module T = struct
     match desc with
     | Ptyp_any -> any ~loc ~attrs ()
     | Ptyp_var s -> var ~loc ~attrs s
-    | Ptyp_arrow {lbl; lbl_loc; arg; ret; arity} ->
-      arrow ~loc ~attrs ~label_loc:lbl_loc ~arity lbl (sub.typ sub arg)
-        (sub.typ sub ret)
+    | Ptyp_arrow {lbl; arg; ret; arity} ->
+      arrow ~loc ~attrs ~arity lbl (sub.typ sub arg) (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_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 ?(label_loc = Location.none) ~arity lbl arg ret =
-    mk ?loc ?attrs (Ptyp_arrow {lbl; lbl_loc = label_loc; arg; ret; arity})
+  let arrow ?loc ?attrs ~arity lbl arg ret =
+    mk ?loc ?attrs (Ptyp_arrow {lbl; 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))
diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli
@@ -57,9 +57,8 @@ module Typ : sig
   val arrow :
     ?loc:loc ->
     ?attrs:attrs ->
-    ?label_loc:loc ->
     arity:arity ->
-    arg_label ->
+    arg_label_loc ->
     core_type ->
     core_type ->
     core_type
diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml
@@ -93,9 +93,8 @@ module T = struct
     match desc with
     | Ptyp_any -> any ~loc ~attrs ()
     | Ptyp_var s -> var ~loc ~attrs s
-    | Ptyp_arrow {lbl; lbl_loc; arg; ret; arity} ->
-      arrow ~loc ~attrs ~label_loc:lbl_loc ~arity lbl (sub.typ sub arg)
-        (sub.typ sub ret)
+    | Ptyp_arrow {lbl; arg; ret; arity} ->
+      arrow ~loc ~attrs ~arity lbl (sub.typ sub arg) (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
@@ -99,6 +99,7 @@ module T = struct
     | Ptyp_any -> any ~loc ~attrs ()
     | Ptyp_var s -> var ~loc ~attrs s
     | Ptyp_arrow (lab, t1, t2) ->
+      let lab = Asttypes.to_arg_label_loc lab in
       arrow ~loc ~attrs ~arity:None lab (sub.typ sub t1) (sub.typ sub t2)
     | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
     | Ptyp_constr (lid, tl) -> (
diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml
@@ -99,6 +99,7 @@ module T = struct
     | Ptyp_any -> any ~loc ~attrs ()
     | Ptyp_var s -> var ~loc ~attrs s
     | Ptyp_arrow {lbl; arg; ret; arity} -> (
+      let lbl = Asttypes.to_arg_label lbl in
       let typ0 = arrow ~loc ~attrs lbl (sub.typ sub arg) (sub.typ sub ret) in
       match arity with
       | None -> typ0
diff --git a/compiler/ml/asttypes.ml b/compiler/ml/asttypes.ml
@@ -91,3 +91,7 @@ let same_arg_label_loc (x : arg_label_loc) y =
     match y with
     | Opt {txt = s0} -> s = s0
     | _ -> false)
+
+let get_lbl_loc = function
+  | Nolbl -> Location.none
+  | Lbl {loc} | Opt {loc} -> loc
diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml
@@ -77,8 +77,7 @@ and core_type_desc =
   | Ptyp_any (*  _ *)
   | Ptyp_var of string (* 'a *)
   | Ptyp_arrow of {
-      lbl: arg_label;
-      lbl_loc: Location.t;
+      lbl: arg_label_loc;
       arg: core_type;
       ret: core_type;
       arity: arity;
diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml
@@ -287,9 +287,9 @@ let string_quot f x = pp f "`%s" x
 
 let rec type_with_label ctxt f (label, c) =
   match label with
-  | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *)
-  | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c
-  | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c
+  | Nolbl -> core_type1 ctxt f c (* otherwise parenthesize *)
+  | Lbl {txt = s} -> pp f "%s:%a" s (core_type1 ctxt) c
+  | Opt {txt = s} -> pp f "?%s:%a" s (core_type1 ctxt) c
 
 and core_type ctxt f x =
   if x.ptyp_attributes <> [] then
diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml
@@ -134,7 +134,7 @@ let rec core_type i ppf x =
       | None -> ()
       | Some n -> line i ppf "arity = %d\n" n
     in
-    arg_label i ppf lbl;
+    arg_label_loc i ppf lbl;
     core_type i ppf arg;
     core_type i ppf ret
   | Ptyp_tuple l ->
diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml
@@ -1879,6 +1879,7 @@ and is_nonexpansive_opt = function
 let rec approx_type env sty =
   match sty.ptyp_desc with
   | Ptyp_arrow {lbl = p; ret = sty; arity} ->
+    let p = Asttypes.to_arg_label 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))
   | Ptyp_tuple args -> newty (Ttuple (List.map (approx_type env) args))
diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml
@@ -328,6 +328,7 @@ and transl_type_aux env policy styp =
     in
     ctyp (Ttyp_var name) ty
   | Ptyp_arrow {lbl; arg = st1; ret = st2; arity} ->
+    let lbl = Asttypes.to_arg_label lbl in
     let cty1 = transl_type env policy st1 in
     let cty2 = transl_type env policy st2 in
     let ty1 = cty1.ctyp_type in
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
diff --git a/compiler/syntax/src/res_parsetree_viewer.mli b/compiler/syntax/src/res_parsetree_viewer.mli
diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml
