Store location directly in the label on Pexp_fun.

cristianoc · cristianoc · commit 783670af0b29 · 2025-01-30T10:48:03.000+01:00
diff --git a/analysis/src/CompletionFrontEnd.ml b/analysis/src/CompletionFrontEnd.ml
@@ -1437,7 +1437,7 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor
             | Some (ctxPath, currentUnlabelledCount) ->
               (processingFun :=
                  match lbl with
-                 | Nolabel -> Some (ctxPath, currentUnlabelledCount + 1)
+                 | Nolbl -> Some (ctxPath, currentUnlabelledCount + 1)
                  | _ -> Some (ctxPath, currentUnlabelledCount));
               if Debug.verbose () then
                 print_endline "[expr_iter] Completing for argument value";
@@ -1447,10 +1447,10 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor
                      functionContextPath = ctxPath;
                      argumentLabel =
                        (match lbl with
-                       | Nolabel ->
+                       | Nolbl ->
                          Unlabelled {argumentPosition = currentUnlabelledCount}
-                       | Optional name -> Optional name
-                       | Labelled name -> Labelled name);
+                       | Opt {txt = name} -> Optional name
+                       | Lbl {txt = name} -> Labelled name);
                    })
           in
           (match defaultExpOpt with
diff --git a/analysis/src/DumpAst.ml b/analysis/src/DumpAst.ml
@@ -218,9 +218,9 @@ and printExprItem expr ~pos ~indentation =
     ^ addIndentation (indentation + 1)
     ^ "arg: "
     ^ (match arg with
-      | Nolabel -> "Nolabel"
-      | Labelled name -> "Labelled(" ^ name ^ ")"
-      | Optional name -> "Optional(" ^ name ^ ")")
+      | Nolbl -> "Nolabel"
+      | Lbl {txt = name} -> "Labelled(" ^ name ^ ")"
+      | Opt {txt = name} -> "Optional(" ^ name ^ ")")
     ^ ",\n"
     ^ addIndentation (indentation + 2)
     ^ "pattern: "
diff --git a/analysis/src/Xform.ml b/analysis/src/Xform.ml
@@ -300,7 +300,7 @@ module AddTypeAnnotation = struct
       match e.pexp_desc with
       | Pexp_fun {arg_label; lhs = pat; rhs = e} ->
         let isUnlabeledOnlyArg =
-          argNum = 1 && arg_label = Nolabel
+          argNum = 1 && arg_label = Nolbl
           &&
           match e.pexp_desc with
           | Pexp_fun _ -> false
diff --git a/compiler/frontend/ast_compatible.ml b/compiler/frontend/ast_compatible.ml
@@ -82,15 +82,7 @@ let fun_ ?(loc = default_loc) ?(attrs = []) ?(async = false) ~arity pat exp =
     pexp_attributes = attrs;
     pexp_desc =
       Pexp_fun
-        {
-          arg_label = Nolabel;
-          label_loc = Location.none;
-          default = None;
-          lhs = pat;
-          rhs = exp;
-          arity;
-          async;
-        };
+        {arg_label = Nolbl; default = None; lhs = pat; rhs = exp; arity; async};
   }
 
 let const_exp_string ?(loc = default_loc) ?(attrs = []) ?delimiter (s : string)
diff --git a/compiler/frontend/ast_pat.mli b/compiler/frontend/ast_pat.mli
@@ -30,6 +30,6 @@ val arity_of_fun : t -> Parsetree.expression -> int
 (** [arity_of_fun pat e] tells the arity of 
     expression [fun pat -> e]*)
 
-val labels_of_fun : Parsetree.expression -> Asttypes.arg_label list
+val labels_of_fun : Parsetree.expression -> Asttypes.arg_label_loc list
 
 val is_single_variable_pattern_conservative : t -> string option
diff --git a/compiler/frontend/ast_uncurry_gen.mli b/compiler/frontend/ast_uncurry_gen.mli
@@ -25,7 +25,7 @@
 val to_method_callback :
   Location.t ->
   Bs_ast_mapper.mapper ->
-  Asttypes.arg_label ->
+  Asttypes.arg_label_loc ->
   Parsetree.pattern ->
   Parsetree.expression ->
   Parsetree.expression_desc
diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml
@@ -311,17 +311,9 @@ module E = struct
            sub vbs)
         (sub.expr sub e)
     (* #end *)
-    | Pexp_fun
-        {
-          arg_label = lab;
-          label_loc;
-          default = def;
-          lhs = p;
-          rhs = e;
-          arity;
-          async;
-        } ->
-      fun_ ~loc ~attrs ~label_loc ~arity ~async lab
+    | Pexp_fun {arg_label = lab; default = def; lhs = p; rhs = e; arity; async}
+      ->
+      fun_ ~loc ~attrs ~arity ~async lab
         (map_opt (sub.expr sub) def)
         (sub.pat sub p) (sub.expr sub e)
     | Pexp_apply {funct = e; args = l; partial} ->
diff --git a/compiler/frontend/bs_syntaxerr.ml b/compiler/frontend/bs_syntaxerr.ml
@@ -104,9 +104,9 @@ let () =
 
 let err loc error = raise (Error (loc, error))
 
-let optional_err loc (lbl : Asttypes.arg_label) =
+let optional_err loc (lbl : Asttypes.arg_label_loc) =
   match lbl with
-  | Optional _ -> raise (Error (loc, Optional_in_uncurried_bs_attribute))
+  | Opt _ -> raise (Error (loc, Optional_in_uncurried_bs_attribute))
   | _ -> ()
 
 let err_if_label loc (lbl : Asttypes.arg_label_loc) =
diff --git a/compiler/frontend/bs_syntaxerr.mli b/compiler/frontend/bs_syntaxerr.mli
@@ -54,6 +54,6 @@ type error =
 
 val err : Location.t -> error -> 'a
 
-val optional_err : Location.t -> Asttypes.arg_label -> unit
+val optional_err : Location.t -> Asttypes.arg_label_loc -> unit
 
 val err_if_label : Location.t -> Asttypes.arg_label_loc -> unit
diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml
@@ -151,11 +151,9 @@ module Exp = struct
   let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a)
   let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a)
   let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c))
-  let fun_ ?loc ?attrs ?(async = false) ?(label_loc = Location.none) ~arity a b
-      c d =
+  let fun_ ?loc ?attrs ?(async = false) ~arity a b c d =
     mk ?loc ?attrs
-      (Pexp_fun
-         {arg_label = a; label_loc; default = b; lhs = c; rhs = d; arity; async})
+      (Pexp_fun {arg_label = a; default = b; lhs = c; rhs = d; arity; async})
   let apply ?loc ?attrs ?(partial = false) funct args =
     mk ?loc ?attrs (Pexp_apply {funct; args; partial})
   let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b))
diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli
@@ -139,9 +139,8 @@ module Exp : sig
     ?loc:loc ->
     ?attrs:attrs ->
     ?async:bool ->
-    ?label_loc:loc ->
     arity:int option ->
-    arg_label ->
+    arg_label_loc ->
     expression option ->
     pattern ->
     expression ->
diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml
@@ -274,17 +274,9 @@ module E = struct
     | Pexp_constant x -> constant ~loc ~attrs x
     | Pexp_let (r, vbs, e) ->
       let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e)
-    | Pexp_fun
-        {
-          arg_label = lab;
-          label_loc;
-          default = def;
-          lhs = p;
-          rhs = e;
-          arity;
-          async;
-        } ->
-      fun_ ~loc ~attrs ~label_loc ~arity ~async lab
+    | Pexp_fun {arg_label = lab; default = def; lhs = p; rhs = e; arity; async}
+      ->
+      fun_ ~loc ~attrs ~arity ~async lab
         (map_opt (sub.expr sub) def)
         (sub.pat sub p) (sub.expr sub e)
     | Pexp_apply {funct = e; args = l; partial} ->
diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml
@@ -305,6 +305,7 @@ module E = struct
     | Pexp_let (r, vbs, e) ->
       let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e)
     | Pexp_fun (lab, def, p, e) ->
+      let lab = Asttypes.to_arg_label_loc lab in
       let async = Ext_list.exists attrs (fun ({txt}, _) -> txt = "res.async") in
       fun_ ~loc ~attrs ~async ~arity:None lab
         (map_opt (sub.expr sub) def)
diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml
@@ -294,6 +294,7 @@ module E = struct
       let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e)
     | Pexp_fun {arg_label = lab; default = def; lhs = p; rhs = e; arity; async}
       -> (
+      let lab = Asttypes.to_arg_label lab in
       let attrs =
         if async then
           ({txt = "res.async"; loc = Location.none}, Pt.PStr []) :: attrs
diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml
@@ -230,8 +230,7 @@ and expression_desc =
        let rec P1 = E1 and ... and Pn = EN in E   (flag = Recursive)
     *)
   | Pexp_fun of {
-      arg_label: arg_label;
-      label_loc: Location.t;
+      arg_label: arg_label_loc;
       default: expression option;
       lhs: pattern;
       rhs: expression;
diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml
@@ -494,10 +494,10 @@ and simple_pattern ctxt (f : Format.formatter) (x : pattern) : unit =
 
 and label_exp ctxt f (l, opt, p) =
   match l with
-  | Nolabel ->
+  | Nolbl ->
     (* single case pattern parens needed here *)
     pp f "%a@ " (simple_pattern ctxt) p
-  | Optional rest -> (
+  | Opt {txt = rest} -> (
     match p with
     | {ppat_desc = Ppat_var {txt; _}; ppat_attributes = []} when txt = rest -> (
       match opt with
@@ -508,7 +508,7 @@ and label_exp ctxt f (l, opt, p) =
       | Some o ->
         pp f "?%s:(%a=@;%a)@;" rest (pattern1 ctxt) p (expression ctxt) o
       | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p))
-  | Labelled l -> (
+  | Lbl {txt = l} -> (
     match p with
     | {ppat_desc = Ppat_var {txt; _}; ppat_attributes = []} when txt = l ->
       pp f "~%s@;" l
@@ -988,7 +988,7 @@ and binding ctxt f {pvb_pat = p; pvb_expr = x; _} =
           | Some arity -> "[arity:" ^ string_of_int arity ^ "]"
         in
         let async_str = if async then "async " else "" in
-        if label = Nolabel then
+        if label = Nolbl then
           pp f "%s%s%a@ %a" async_str arity_str (simple_pattern ctxt) p
             pp_print_pexp_function e
         else
diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml
@@ -110,10 +110,6 @@ let option i f ppf x =
 let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li
 let string i ppf s = line i ppf "\"%s\"\n" s
 let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s
-let arg_label i ppf = function
-  | Nolabel -> line i ppf "Nolabel\n"
-  | Optional s -> line i ppf "Optional \"%s\"\n" s
-  | Labelled s -> line i ppf "Labelled \"%s\"\n" s
 
 let arg_label_loc i ppf = function
   | Nolbl -> line i ppf "Nolabel\n"
@@ -251,7 +247,7 @@ and expression i ppf x =
       | None -> ()
       | Some arity -> line i ppf "arity:%d\n" arity
     in
-    arg_label i ppf l;
+    arg_label_loc i ppf l;
     option i expression ppf eo;
     pattern i ppf p;
     expression i ppf e
diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml
@@ -1898,6 +1898,7 @@ let rec type_approx env sexp =
   match sexp.pexp_desc with
   | Pexp_let (_, _, e) -> type_approx env e
   | Pexp_fun {arg_label = p; rhs = e; arity} ->
+    let p = Asttypes.to_arg_label p in
     let ty = if is_optional p then type_option (newvar ()) else newvar () in
     newty (Tarrow (p, ty, type_approx env e, Cok, arity))
   | Pexp_match (_, {pc_rhs = e} :: _) -> type_approx env e
@@ -2363,6 +2364,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp
         arity;
         async;
       } ->
+    let l = Asttypes.to_arg_label l in
     assert (is_optional l);
     (* default allowed only with optional argument *)
     let open Ast_helper in
@@ -2405,6 +2407,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp
       [Exp.case pat body]
   | Pexp_fun
       {arg_label = l; default = None; lhs = spat; rhs = sbody; arity; async} ->
+    let l = Asttypes.to_arg_label l in
     type_function ?in_function ~arity ~async loc sexp.pexp_attributes env
       ty_expected l
       [Ast_helper.Exp.case spat sbody]
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
