Capture pc_loc instead of pc_bar

nojaf · nojaf · commit e53ab8a51c37 · 2025-05-01T17:11:58.000+02:00
diff --git a/analysis/src/Codemod.ml b/analysis/src/Codemod.ml
@@ -19,7 +19,8 @@ let transform ~path ~pos ~debug ~typ ~hint =
       let cases =
         collectPatterns pattern
         |> List.map (fun (p : Parsetree.pattern) ->
-               Ast_helper.Exp.case p (TypeUtils.Codegen.mkFailWithExp ()))
+               Ast_helper.Exp.case p.ppat_loc p
+                 (TypeUtils.Codegen.mkFailWithExp ()))
       in
       let result = ref None in
       let mkIterator ~pos ~result =
diff --git a/analysis/src/TypeUtils.ml b/analysis/src/TypeUtils.ml
@@ -1044,7 +1044,7 @@ module Codegen = struct
       Some
         (patterns
         |> List.map (fun (pat : Parsetree.pattern) ->
-               Ast_helper.Exp.case pat (mkFailWithExp ())))
+               Ast_helper.Exp.case pat.ppat_loc pat (mkFailWithExp ())))
 end
 
 let getModulePathRelativeToEnv ~debug ~(env : QueryEnv.t) ~envFromItem path =
diff --git a/analysis/src/Xform.ml b/analysis/src/Xform.ml
@@ -105,8 +105,13 @@ module IfThenElse = struct
           let mkMatch ~arg ~pat =
             let cases =
               [
-                Ast_helper.Exp.case pat e1;
-                Ast_helper.Exp.case (Ast_helper.Pat.any ()) e2;
+                Ast_helper.Exp.case
+                  {
+                    pat.Parsetree.ppat_loc with
+                    Location.loc_end = e1.pexp_loc.loc_end;
+                  }
+                  pat e1;
+                Ast_helper.Exp.case e2.pexp_loc (Ast_helper.Pat.any ()) e2;
               ]
             in
             Ast_helper.Exp.match_ ~loc:e.pexp_loc ~attrs:e.pexp_attributes arg
diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml
@@ -539,9 +539,9 @@ let default_mapper =
           ~attrs:(this.attributes this pld_attributes));
     cases = (fun this l -> List.map (this.case this) l);
     case =
-      (fun this {pc_bar; pc_lhs; pc_guard; pc_rhs} ->
+      (fun this {pc_loc; pc_lhs; pc_guard; pc_rhs} ->
         {
-          pc_bar;
+          pc_loc = this.location this pc_loc;
           pc_lhs = this.pat this pc_lhs;
           pc_guard = map_opt (this.expr this) pc_guard;
           pc_rhs = this.expr this pc_rhs;
diff --git a/compiler/frontend/bs_builtin_ppx.ml b/compiler/frontend/bs_builtin_ppx.ml
@@ -167,7 +167,15 @@ let expr_mapper ~async_context ~in_function_def (self : mapper)
           pexp_desc =
             Pexp_match
               ( pvb_expr,
-                [{pc_bar = None; pc_lhs = p; pc_guard = None; pc_rhs = body}] );
+                [
+                  {
+                    pc_loc =
+                      {p.ppat_loc with Location.loc_end = body.pexp_loc.loc_end};
+                    pc_lhs = p;
+                    pc_guard = None;
+                    pc_rhs = body;
+                  };
+                ] );
           pexp_attributes = e.pexp_attributes @ pvb_attributes;
         })
   (* let [@warning "a"] {a;b} = c in body
diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml
@@ -208,8 +208,8 @@ module Exp = struct
               jsx_container_element_closing_tag = e;
             }))
 
-  let case ?bar lhs ?guard rhs =
-    {pc_bar = bar; pc_lhs = lhs; pc_guard = guard; pc_rhs = rhs}
+  let case loc lhs ?guard rhs =
+    {pc_loc = loc; pc_lhs = lhs; pc_guard = guard; pc_rhs = rhs}
 
   let make_list_expression loc seq ext_opt =
     let rec handle_seq = function
diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli
@@ -231,8 +231,7 @@ module Exp : sig
     Parsetree.jsx_closing_container_tag option ->
     expression
 
-  val case :
-    ?bar:Lexing.position -> pattern -> ?guard:expression -> expression -> case
+  val case : Location.t -> pattern -> ?guard:expression -> expression -> case
   val await : ?loc:loc -> ?attrs:attrs -> expression -> expression
 
   val make_list_expression :
diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml
@@ -488,9 +488,9 @@ let default_mapper =
           ~attrs:(this.attributes this pld_attributes));
     cases = (fun this l -> List.map (this.case this) l);
     case =
-      (fun this {pc_bar; pc_lhs; pc_guard; pc_rhs} ->
+      (fun this {pc_loc; pc_lhs; pc_guard; pc_rhs} ->
         {
-          pc_bar;
+          pc_loc = this.location this pc_loc;
           pc_lhs = this.pat this pc_lhs;
           pc_guard = map_opt (this.expr this) pc_guard;
           pc_rhs = this.expr this pc_rhs;
diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml
@@ -665,7 +665,9 @@ let default_mapper =
     case =
       (fun this {pc_lhs; pc_guard; pc_rhs} ->
         {
-          pc_bar = None;
+          pc_loc =
+            this.location this
+              {pc_lhs.ppat_loc with Location.loc_end = pc_rhs.pexp_loc.loc_end};
           pc_lhs = this.pat this pc_lhs;
           pc_guard = map_opt (this.expr this) pc_guard;
           pc_rhs = this.expr this pc_rhs;
diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml
@@ -381,7 +381,7 @@ and jsx_closing_container_tag = {
 
 and case = {
   (* (P -> E) or (P when E0 -> E) *)
-  pc_bar: Lexing.position option;
+  pc_loc: Location.t;
   pc_lhs: pattern;
   pc_guard: expression option;
   pc_rhs: expression;
diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml
@@ -681,10 +681,8 @@ and longident_x_pattern i ppf (li, p, opt) =
   line i ppf "%a%s\n" fmt_longident_loc li (if opt then "?" else "");
   pattern (i + 1) ppf p
 
-and case i ppf {pc_bar; pc_lhs; pc_guard; pc_rhs} =
-  line i ppf "<case>\n";
-  pc_bar
-  |> Option.iter (fun bar -> line i ppf "| %a\n" (fmt_position false) bar);
+and case i ppf {pc_loc; pc_lhs; pc_guard; pc_rhs} =
+  line i ppf "<case> %a\n" fmt_location pc_loc;
   pattern (i + 1) ppf pc_lhs;
   (match pc_guard with
   | None -> ()
diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml
@@ -2371,7 +2371,14 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp
     type_expect ?in_function env
       {
         sexp with
-        pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody]);
+        pexp_desc =
+          Pexp_match
+            ( sval,
+              [
+                Ast_helper.Exp.case
+                  {spat.ppat_loc with Location.loc_end = sbody.pexp_loc.loc_end}
+                  spat sbody;
+              ] );
       }
       ty_expected
   | Pexp_let (rec_flag, spat_sexp_list, sbody) ->
@@ -2414,12 +2421,12 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp
     let default_loc = default.pexp_loc in
     let scases =
       [
-        Exp.case
+        Exp.case default_loc
           (Pat.construct ~loc:default_loc
              (mknoloc Longident.(Ldot (Lident "*predef*", "Some")))
              (Some (Pat.var ~loc:default_loc (mknoloc "*sth*"))))
           (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*")));
-        Exp.case
+        Exp.case default_loc
           (Pat.construct ~loc:default_loc
              (mknoloc Longident.(Ldot (Lident "*predef*", "None")))
              None)
@@ -2447,13 +2454,17 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp
     in
     type_function ?in_function ~arity ~async loc sexp.pexp_attributes env
       ty_expected l
-      [Exp.case pat body]
+      [Exp.case sloc pat body]
   | Pexp_fun
       {arg_label = l; default = None; lhs = spat; rhs = sbody; arity; async} ->
     let l = Asttypes.to_noloc l in
     type_function ?in_function ~arity ~async loc sexp.pexp_attributes env
       ty_expected l
-      [Ast_helper.Exp.case spat sbody]
+      [
+        Ast_helper.Exp.case
+          {spat.ppat_loc with Location.loc_end = sbody.pexp_loc.loc_end}
+          spat sbody;
+      ]
   | Pexp_apply {funct = sfunct; args = sargs; partial} ->
     assert (sargs <> []);
     begin_def ();
diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml
@@ -511,12 +511,12 @@ let vb_match ~expr (name, default, _, alias, loc, _) =
         (Exp.match_
            (Exp.ident {txt = Lident ("__" ^ alias); loc = Location.none})
            [
-             Exp.case
+             Exp.case Location.none
                (Pat.construct
                   (Location.mknoloc @@ Lident "Some")
                   (Some (Pat.var (Location.mknoloc label))))
                (Exp.ident (Location.mknoloc @@ Lident label));
-             Exp.case
+             Exp.case Location.none
                (Pat.construct (Location.mknoloc @@ Lident "None") None)
                default;
            ])
diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml
@@ -3431,8 +3431,10 @@ and parse_if_let_expr start_pos p =
     ~attrs:[if_let_attr; suppress_fragile_match_warning_attr]
     ~loc condition_expr
     [
-      Ast_helper.Exp.case pattern then_expr;
-      Ast_helper.Exp.case (Ast_helper.Pat.any ()) else_expr;
+      Ast_helper.Exp.case
+        {pattern.ppat_loc with Location.loc_end = loc.loc_end}
+        pattern then_expr;
+      Ast_helper.Exp.case else_expr.pexp_loc (Ast_helper.Pat.any ()) else_expr;
     ]
 
 and parse_if_or_if_let_expression p =
@@ -3557,7 +3559,8 @@ and parse_pattern_match_case p =
     let rhs = parse_expr_block p in
     Parser.end_region p;
     Parser.eat_breadcrumb p;
-    Some (Ast_helper.Exp.case ~bar lhs ?guard rhs)
+    let loc = mk_loc bar rhs.pexp_loc.loc_end in
+    Some (Ast_helper.Exp.case loc lhs ?guard rhs)
   | _ ->
     Parser.end_region p;
     Parser.eat_breadcrumb p;
