Store label location in type argument instead of attribute.

cristianoc · cristianoc · commit 60cb16efa8b5 · 2025-01-30T14:28:13.000+01:00
diff --git a/compiler/frontend/ast_compatible.ml b/compiler/frontend/ast_compatible.ml
@@ -126,14 +126,17 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn
 let label_arrow ?(loc = default_loc) ?(attrs = []) ~arity s arg ret : core_type
     =
   {
-    ptyp_desc = Ptyp_arrow {lbl = Labelled s; arg; ret; arity};
+    ptyp_desc =
+      Ptyp_arrow {lbl = Labelled s; lbl_loc = Location.none; arg; ret; arity};
     ptyp_loc = loc;
     ptyp_attributes = attrs;
   }
 
 let opt_arrow ?(loc = default_loc) ?(attrs = []) ~arity s arg ret : core_type =
   {
-    ptyp_desc = Ptyp_arrow {lbl = Asttypes.Optional s; arg; ret; arity};
+    ptyp_desc =
+      Ptyp_arrow
+        {lbl = Asttypes.Optional s; lbl_loc = Location.none; 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
@@ -142,7 +142,15 @@ 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
+              {
+                lbl = label;
+                lbl_loc = Location.none;
+                arg = ty;
+                ret = acc;
+                arity = None;
+              };
           ptyp_loc = loc;
           ptyp_attributes = attr;
         })
diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml
@@ -101,8 +101,9 @@ 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 {lbl; lbl_loc; arg; ret; arity} ->
+      arrow ~loc ~attrs ~label_loc:lbl_loc ~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 ~arity lbl arg ret =
-    mk ?loc ?attrs (Ptyp_arrow {lbl; arg; ret; arity})
+  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 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))
@@ -82,8 +82,8 @@ module Typ = struct
         | Ptyp_var x ->
           check_variable var_names t.ptyp_loc x;
           Ptyp_var x
-        | Ptyp_arrow {lbl = label; arg; ret; arity = a} ->
-          Ptyp_arrow {lbl = label; arg = loop arg; ret = loop ret; arity = a}
+        | Ptyp_arrow ({arg; ret} as arr) ->
+          Ptyp_arrow {arr with arg = loop arg; 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
@@ -57,6 +57,7 @@ module Typ : sig
   val arrow :
     ?loc:loc ->
     ?attrs:attrs ->
+    ?label_loc:loc ->
     arity:arity ->
     arg_label ->
     core_type ->
diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml
@@ -93,8 +93,9 @@ 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 {lbl; lbl_loc; arg; ret; arity} ->
+      arrow ~loc ~attrs ~label_loc:lbl_loc ~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/parsetree.ml b/compiler/ml/parsetree.ml
@@ -76,7 +76,13 @@ and 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 {
+      lbl: arg_label;
+      lbl_loc: Location.t;
+      arg: core_type;
+      ret: core_type;
+      arity: arity;
+    }
     (* T1 -> T2       Simple
        ~l:T1 -> T2    Labelled
        ?l:T1 -> T2    Optional
diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml
@@ -168,22 +168,23 @@ let arrow_type ct =
   let rec process attrs_before acc typ =
     match typ with
     | {
-     ptyp_desc = Ptyp_arrow {lbl = Nolabel as lbl; arg; ret};
+     ptyp_desc = Ptyp_arrow {lbl = Nolabel as lbl; lbl_loc; arg; ret};
      ptyp_attributes = [];
     } ->
-      let arg = ([], lbl, arg) in
+      let arg = ([], lbl, lbl_loc, arg) in
       process attrs_before (arg :: acc) ret
     | {
-     ptyp_desc = Ptyp_arrow {lbl = Nolabel as lbl; arg; ret};
+     ptyp_desc = Ptyp_arrow {lbl = Nolabel as lbl; lbl_loc; arg; ret};
      ptyp_attributes = [({txt = "bs"}, _)] as attrs;
     } ->
-      let arg = (attrs, lbl, arg) in
+      let arg = (attrs, lbl, lbl_loc, arg) in
       process attrs_before (arg :: acc) ret
     | {ptyp_desc = Ptyp_arrow {lbl = Nolabel}} as return_type ->
       let args = List.rev acc in
       (attrs_before, args, return_type)
-    | {ptyp_desc = Ptyp_arrow {lbl; arg; ret}; ptyp_attributes = attrs} ->
-      let arg = (attrs, lbl, arg) in
+    | {ptyp_desc = Ptyp_arrow {lbl; lbl_loc; arg; ret}; ptyp_attributes = attrs}
+      ->
+      let arg = (attrs, lbl, lbl_loc, arg) in
       process attrs_before (arg :: acc) ret
     | typ -> (attrs_before, List.rev acc, typ)
   in
@@ -1938,15 +1939,14 @@ and walk_object_field field t comments =
 
 and walk_type_parameters type_parameters t comments =
   visit_list_but_continue_with_remaining_comments
-    ~get_loc:(fun (_, _, typexpr) ->
-      match typexpr.Parsetree.ptyp_attributes with
-      | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _attrs ->
-        {loc with loc_end = typexpr.ptyp_loc.loc_end}
-      | _ -> typexpr.ptyp_loc)
+    ~get_loc:(fun (_, _, lbl_loc, typexpr) ->
+      if lbl_loc <> Location.none then
+        {lbl_loc with loc_end = typexpr.Parsetree.ptyp_loc.loc_end}
+      else typexpr.ptyp_loc)
     ~walk_node:walk_type_parameter ~newline_delimited:false type_parameters t
     comments
 
-and walk_type_parameter (_attrs, _lbl, typexpr) t comments =
+and walk_type_parameter (_attrs, _lbl, _lbl_loc, typexpr) t comments =
   let before_typ, inside_typ, after_typ =
     partition_by_loc comments typexpr.ptyp_loc
   in
diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml
@@ -171,6 +171,7 @@ type argument = {label: Asttypes.arg_label; expr: Parsetree.expression}
 type type_parameter = {
   attrs: Ast_helper.attrs;
   label: Asttypes.arg_label;
+  label_loc: Location.t;
   typ: Parsetree.core_type;
   start_pos: Lexing.position;
 }
@@ -4261,20 +4262,15 @@ and parse_type_parameter p =
     | Tilde -> (
       Parser.next p;
       let name, loc = parse_lident p in
-      let lbl_loc_attr =
-        (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr [])
-      in
       Parser.expect ~grammar:Grammar.TypeExpression Colon p;
-      let typ =
-        let typ = parse_typ_expr p in
-        {typ with ptyp_attributes = lbl_loc_attr :: typ.ptyp_attributes}
-      in
+      let typ = parse_typ_expr p in
       match p.Parser.token with
       | Equal ->
         Parser.next p;
         Parser.expect Question p;
-        Some {attrs; label = Optional name; typ; start_pos}
-      | _ -> Some {attrs; label = Labelled name; typ; start_pos})
+        Some {attrs; label = Optional name; label_loc = loc; typ; start_pos}
+      | _ ->
+        Some {attrs; label = Labelled name; label_loc = loc; typ; start_pos})
     | Lident _ -> (
       let name, loc = parse_lident p in
       match p.token with
@@ -4292,8 +4288,9 @@ and parse_type_parameter p =
         | Equal ->
           Parser.next p;
           Parser.expect Question p;
-          Some {attrs; label = Optional name; typ; start_pos}
-        | _ -> Some {attrs; label = Labelled name; typ; start_pos})
+          Some {attrs; label = Optional name; label_loc = loc; typ; start_pos}
+        | _ ->
+          Some {attrs; label = Labelled name; label_loc = loc; typ; start_pos})
       | _ ->
         let constr = Location.mkloc (Longident.Lident name) loc in
         let args = parse_type_constructor_args ~constr_name:constr p in
@@ -4305,13 +4302,27 @@ and parse_type_parameter p =
 
         let typ = parse_arrow_type_rest ~es6_arrow:true ~start_pos typ p in
         let typ = parse_type_alias p typ in
-        Some {attrs = []; label = Nolabel; typ; start_pos})
+        Some
+          {
+            attrs = [];
+            label = Nolabel;
+            label_loc = Location.none;
+            typ;
+            start_pos;
+          })
     | _ ->
       let typ = parse_typ_expr p in
       let typ_with_attributes =
         {typ with ptyp_attributes = List.concat [attrs; typ.ptyp_attributes]}
       in
-      Some {attrs = []; label = Nolabel; typ = typ_with_attributes; start_pos}
+      Some
+        {
+          attrs = [];
+          label = Nolabel;
+          label_loc = Location.none;
+          typ = typ_with_attributes;
+          start_pos;
+        }
   else None
 
 (* (int, ~x:string, float) *)
@@ -4324,7 +4335,7 @@ and parse_type_parameters p =
     let loc = mk_loc start_pos p.prev_end_pos in
     let unit_constr = Location.mkloc (Longident.Lident "unit") loc in
     let typ = Ast_helper.Typ.constr unit_constr [] in
-    [{attrs = []; label = Nolabel; typ; start_pos}]
+    [{attrs = []; label = Nolabel; label_loc = Location.none; typ; start_pos}]
   | _ ->
     let params =
       parse_comma_delimited_region ~grammar:Grammar.TypeParameters
@@ -4368,7 +4379,8 @@ and parse_es6_arrow_type ~attrs p =
     let return_type_arity = 0 in
     let _paramNum, typ, _arity =
       List.fold_right
-        (fun {attrs; label = arg_lbl; typ; start_pos} (param_num, t, arity) ->
+        (fun {attrs; label = arg_lbl; label_loc; typ; start_pos}
+             (param_num, t, arity) ->
           let loc = mk_loc start_pos end_pos in
           let arity =
             (* Workaround for ~lbl: @as(json`false`) _, which changes the arity *)
@@ -4387,7 +4399,8 @@ and parse_es6_arrow_type ~attrs p =
             | _ -> arity
           in
           let t_arg =
-            Ast_helper.Typ.arrow ~loc ~attrs ~arity:None arg_lbl typ t
+            Ast_helper.Typ.arrow ~loc ~label_loc ~attrs ~arity:None arg_lbl typ
+              t
           in
           if param_num = 1 then
             (param_num - 1, Ast_uncurried.uncurried_type ~arity t_arg, 1)
diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml
@@ -11,10 +11,10 @@ let arrow_type ?(max_arity = max_int) ct =
       when acc <> [] ->
       (attrs_before, List.rev acc, typ)
     | {
-     ptyp_desc = Ptyp_arrow {lbl = Nolabel as lbl; arg; ret};
+     ptyp_desc = Ptyp_arrow {lbl = Nolabel as lbl; lbl_loc; arg; ret};
      ptyp_attributes = [];
     } ->
-      let arg = ([], lbl, arg) in
+      let arg = ([], lbl, lbl_loc, arg) in
       process attrs_before (arg :: acc) ret (arity - 1)
     | {
      ptyp_desc = Ptyp_arrow {lbl = Nolabel};
@@ -28,7 +28,8 @@ let arrow_type ?(max_arity = max_int) ct =
       let args = List.rev acc in
       (attrs_before, args, return_type)
     | {
-     ptyp_desc = Ptyp_arrow {lbl = (Labelled _ | Optional _) as lbl; arg; ret};
+     ptyp_desc =
+       Ptyp_arrow {lbl = (Labelled _ | Optional _) as lbl; lbl_loc; arg; ret};
      ptyp_attributes = attrs;
     } ->
       (* Res_core.parse_es6_arrow_type has a workaround that removed an extra arity for the function if the
@@ -43,7 +44,7 @@ let arrow_type ?(max_arity = max_int) ct =
           arity
         | _ -> arity - 1
       in
-      let arg = (attrs, lbl, arg) in
+      let arg = (attrs, lbl, lbl_loc, arg) in
       process attrs_before (arg :: acc) ret arity
     | typ -> (attrs_before, List.rev acc, typ)
   in
diff --git a/compiler/syntax/src/res_parsetree_viewer.mli b/compiler/syntax/src/res_parsetree_viewer.mli
@@ -5,7 +5,11 @@ val arrow_type :
   ?max_arity:int ->
   Parsetree.core_type ->
   Parsetree.attributes
-  * (Parsetree.attributes * Asttypes.arg_label * Parsetree.core_type) list
+  * (Parsetree.attributes
+    * Asttypes.arg_label
+    * Location.t
+    * Parsetree.core_type)
+    list
   * Parsetree.core_type
 
 val functor_type :
diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml
@@ -1606,7 +1606,7 @@ and print_typ_expr ~(state : State.t) (typ_expr : Parsetree.core_type) cmt_tbl =
     in
     match args with
     | [] -> Doc.nil
-    | [([], Nolabel, n)] ->
+    | [([], Nolabel, _, n)] ->
       let has_attrs_before = not (attrs_before = []) in
       let attrs =
         if has_attrs_before then
@@ -1931,7 +1931,7 @@ and print_object_field ~state (field : Parsetree.object_field) cmt_tbl =
 (* es6 arrow type arg
  * type t = (~foo: string, ~bar: float=?, unit) => unit
  * i.e. ~foo: string, ~bar: float *)
-and print_type_parameter ~state (attrs, lbl, typ) cmt_tbl =
+and print_type_parameter ~state (attrs, lbl, lbl_loc, typ) cmt_tbl =
   (* Converting .ml code to .res requires processing uncurried attributes *)
   let attrs = print_attributes ~state attrs cmt_tbl in
   let label =
@@ -1947,13 +1947,13 @@ and print_type_parameter ~state (attrs, lbl, typ) cmt_tbl =
     | Asttypes.Nolabel | Labelled _ -> Doc.nil
     | Optional _lbl -> Doc.text "=?"
   in
-  let loc, typ =
+  let typ =
     match typ.ptyp_attributes with
-    | ({Location.txt = "res.namedArgLoc"; loc}, _) :: attrs ->
-      ( {loc with loc_end = typ.ptyp_loc.loc_end},
-        {typ with ptyp_attributes = attrs} )
-    | _ -> (typ.ptyp_loc, typ)
+    | ({Location.txt = "res.namedArgLoc"}, _) :: attrs ->
+      {typ with ptyp_attributes = attrs}
+    | _ -> typ
   in
+  let loc = {lbl_loc with loc_end = typ.ptyp_loc.loc_end} in
   let doc =
     Doc.group
       (Doc.concat
diff --git a/tests/syntax_tests/data/parsing/errors/other/expected/regionMissingComma.res.txt b/tests/syntax_tests/data/parsing/errors/other/expected/regionMissingComma.res.txt
@@ -23,8 +23,7 @@
   Did you forget a `,` here?
 
 external make :
-  ?style:((ReactDOMRe.Style.t)[@res.namedArgLoc ]) ->
-    ?image:((bool)[@res.namedArgLoc ]) -> React.element (a:2) =
+  ?style:ReactDOMRe.Style.t -> ?image:bool -> React.element (a:2) =
     "ModalContent"
 type nonrec 'extraInfo student =
   {
diff --git a/tests/syntax_tests/data/parsing/errors/typexpr/expected/arrow.res.txt b/tests/syntax_tests/data/parsing/errors/typexpr/expected/arrow.res.txt
@@ -39,10 +39,7 @@ module Error2 =
     type nonrec observation =
       {
       observed: int ;
-      onStep:
-        currentValue:((unit)[@res.namedArgLoc ]) ->
-          [%rescript.typehole ] (a:1)
-        }
+      onStep: currentValue:unit -> [%rescript.typehole ] (a:1) }
   end
 module Error3 =
   struct
diff --git a/tests/syntax_tests/data/parsing/errors/typexpr/expected/garbage.res.txt b/tests/syntax_tests/data/parsing/errors/typexpr/expected/garbage.res.txt
@@ -8,6 +8,5 @@
 
   I'm not sure what to parse here when looking at "?".
 
-external printName :
-  name:((unit)[@res.namedArgLoc ]) -> unit (a:1) = "printName"[@@module
-                                                                {js|moduleName|js}]
+external printName : name:unit -> unit (a:1) = "printName"[@@module
+                                                            {js|moduleName|js}]
diff --git a/tests/syntax_tests/data/parsing/grammar/signature/expected/external.res.txt b/tests/syntax_tests/data/parsing/grammar/signature/expected/external.res.txt
@@ -2,8 +2,7 @@ module type Signature  =
   sig
     type nonrec t
     external linkProgram :
-      t -> program:((webGlProgram)[@res.namedArgLoc ]) -> unit (a:2) =
-        "linkProgram"[@@send ]
+      t -> program:webGlProgram -> unit (a:2) = "linkProgram"[@@send ]
     external add_nat : nat -> int -> int -> int (a:3) = "add_nat_bytecode"
     external svg : unit -> React.element (a:1) = "svg"
     external svg : unit -> React.element (a:1) = "svg"
diff --git a/tests/syntax_tests/data/parsing/grammar/structure/expected/externalDefinition.res.txt b/tests/syntax_tests/data/parsing/grammar/structure/expected/externalDefinition.res.txt
@@ -1,9 +1,7 @@
 external clear : t -> int -> unit (a:2) = "clear"
 external add_nat : nat -> int (a:1) = "add_nat_bytecode"
 external attachShader :
-  t ->
-    program:((webGlProgram)[@res.namedArgLoc ]) ->
-      shader:((webGlShader)[@res.namedArgLoc ]) -> unit (a:3) =
+  t -> program:webGlProgram -> shader:webGlShader -> unit (a:3) =
     "attachShader"[@@send ]
 external svg : unit -> React.element (a:1) = "svg"
 external svg : unit -> React.element (a:1) = "svg"
diff --git a/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/privateTypeEquation.res.txt b/tests/syntax_tests/data/parsing/grammar/typedefinition/expected/privateTypeEquation.res.txt
diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt
diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/parenthesized.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/parenthesized.res.txt
diff --git a/tests/syntax_tests/data/ppx/react/expected/firstClassModules.res.txt b/tests/syntax_tests/data/ppx/react/expected/firstClassModules.res.txt
diff --git a/tests/syntax_tests/data/ppx/react/expected/firstClassModules.resi.txt b/tests/syntax_tests/data/ppx/react/expected/firstClassModules.resi.txt

Original file line number	Diff line number	Diff line change
`@@ -126,14 +126,17 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn`
`126`	`126`	`let label_arrow ?(loc = default_loc) ?(attrs = []) ~arity s arg ret : core_type`
`127`	`127`	`=`
`128`	`128`	`{`
`129`		`- ptyp_desc = Ptyp_arrow {lbl = Labelled s; arg; ret; arity};`
	`129`	`+ ptyp_desc =`
	`130`	`+ Ptyp_arrow {lbl = Labelled s; lbl_loc = Location.none; arg; ret; arity};`
`130`	`131`	`ptyp_loc = loc;`
`131`	`132`	`ptyp_attributes = attrs;`
`132`	`133`	`}`
`133`	`134`
`134`	`135`	`let opt_arrow ?(loc = default_loc) ?(attrs = []) ~arity s arg ret : core_type =`
`135`	`136`	`{`
`136`		`- ptyp_desc = Ptyp_arrow {lbl = Asttypes.Optional s; arg; ret; arity};`
	`137`	`+ ptyp_desc =`
	`138`	`+ Ptyp_arrow`
	`139`	`+ {lbl = Asttypes.Optional s; lbl_loc = Location.none; arg; ret; arity};`
`137`	`140`	`ptyp_loc = loc;`
`138`	`141`	`ptyp_attributes = attrs;`
`139`	`142`	`}`