Treat the destruction in case of field punning

CHANGES.md

@@ -13,6 +13,8 @@ Thu Feb 22 14:00:42 CET 2024
     - Jump to `module-type` (#1728, partially fixes #1656)
     - Exposes stable functions for configuration handling and pattern variable
       destruction. (#1730)
+    - Reconstruction of the record field in the event of destruction on a record punning field
+      (#1734, fixes #1661)
   + editor modes
     - vim: load merlin under the ocamlinterface and ocamllex filetypes (#1340)
     - Fix merlinpp not using binary file open (#1725, fixes #1724)

src/analysis/destruct.ml

@@ -481,6 +481,27 @@ let find_branch patterns sub =
   in
   aux [] patterns
 
+(* In the presence of record punning fields, the definition must be reconstructed
+   with the label. ie: [{a; b}] with destruction on [a] becomes *)
+(*  [{a = destruct_result; b}]. *)
+let find_field_name_for_punning_field patt = function
+  | Pattern {pat_desc = Tpat_record (fields, _); _} :: _ ->
+    List.find_opt ~f:(fun (_, _, opat) ->
+        let ppat_loc = patt.Typedtree.pat_loc
+        and opat_loc = opat.Typedtree.pat_loc in
+        log ~title:"node_expression" "LOC = ppat: %s - opat: %s"
+            (Location_aux.print () ppat_loc) (Location_aux.print () opat_loc);
+        Location_aux.equal ppat_loc opat_loc
+      ) fields |> Option.map ~f:(fun (_, label, _) -> label)
+  | _ -> None
+
+let print_pretty ?punning_field config source subject =
+  let result = Mreader.print_pretty config source subject in
+  match punning_field with
+  | None -> result
+  | Some label ->
+    label.Types.lbl_name ^ " = " ^ result
+
 let rec node config source selected_node parents =
   let open Extend_protocol.Reader in
   let loc = Mbrowse.node_loc selected_node in
@@ -562,6 +583,8 @@ let rec node config source selected_node parents =
         | Computation -> raise (Not_allowed ("computation pattern"));
         | Value ->
           let _patt : Typedtree.value Typedtree.general_pattern = patt in
+          (* log ~title:"node_expression" "%a" Logger.fmt (fun fmt -> Printtyped.pattern 0 fmt patt ); *)
+          (* log ~title:"node_expression" "POOOOO = %s\nEnd" (Mbrowse.print_node () (List.hd parents)); *)
           if not (destructible patt) then raise Nothing_to_do else
             let ty = patt.Typedtree.pat_type in
             begin match gen_patterns patt.Typedtree.pat_env ty with
@@ -571,9 +594,9 @@ let rec node config source selected_node parents =
             | [ more_precise ] ->
               (* If only one pattern is generated, then we're only refining the
                 current pattern, not generating new branches. *)
+              let punning_field = find_field_name_for_punning_field patt parents in
               let ppat = filter_pat_attr (Untypeast.untype_pattern more_precise) in
-              let str = Mreader.print_pretty
-                  config source (Pretty_pattern ppat) in
+              let str = print_pretty ?punning_field config source (Pretty_pattern ppat) in
               patt.Typedtree.pat_loc, str
             | sub_patterns ->
               let rev_before, after, top_patt =
@@ -612,11 +635,11 @@ let rec node config source selected_node parents =
                 in
                 (* Format.eprintf "por %a \n%!" (Printtyped.pattern 0) p; *)
                 let ppat = filter_pat_attr (Untypeast.untype_pattern p) in
+
                 (* Format.eprintf "ppor %a \n%!" (Pprintast.pattern) ppat; *)
-                let str = Mreader.print_pretty
-                    config source (Pretty_pattern ppat) in
-                (* Format.eprintf "STR: %s \n %!" str; *)
-                top_patt.Typedtree.pat_loc, str
+                let str = Mreader.print_pretty config source (Pretty_pattern ppat) in
+                  (* Format.eprintf "STR: %s \n %!" str; *)
+                  top_patt.Typedtree.pat_loc, str
             end
         end
       end