Fix renamed field access in inline records (#6551)

* add remaining part of melange-re/melange#732

* call the right fld_record_ functions

* update changelog

Author: tsnobip

CHANGELOG.md

@@ -14,6 +14,7 @@
 
 #### :bug: Bug Fix
 
+- Renamed inline record fields : fix renamed field access in inline records https://github.com/rescript-lang/rescript-compiler/pull/6551
 - Fixed issue with coercions sometimes raising a `Not_found` instead of giving a proper error message. https://github.com/rescript-lang/rescript-compiler/pull/6574
 - Fix issue with recursive modules and uncurried. https://github.com/rescript-lang/rescript-compiler/pull/6575
 

jscomp/core/bs_conditional_initial.ml

@@ -44,10 +44,6 @@ let setup_env () =
   Builtin_attributes.check_bs_attributes_inclusion := Record_attributes_check.check_bs_attributes_inclusion;
   Builtin_attributes.check_duplicated_labels :=
     Record_attributes_check.check_duplicated_labels;
-  Lambda.fld_record := Record_attributes_check.fld_record;
-  Lambda.fld_record_set := Record_attributes_check.fld_record_set;
-  Lambda.blk_record := Record_attributes_check.blk_record;
-  Lambda.blk_record_inlined := Record_attributes_check.blk_record_inlined;
   Matching.names_from_construct_pattern := 
     Matching_polyfill.names_from_construct_pattern;
 

jscomp/core/record_attributes_check.ml

@@ -24,7 +24,7 @@
 
 type label = Types.label_description
 
-let find_name = Matching.find_name
+let find_name = Lambda.find_name
 
 let find_name_with_loc (attr : Parsetree.attribute) : string Asttypes.loc option
     =
@@ -40,34 +40,6 @@ let find_name_with_loc (attr : Parsetree.attribute) : string Asttypes.loc option
       Some { txt = s; loc }
   | _ -> None
 
-let fld_record (lbl : label) =
-  Lambda.Fld_record
-    {
-      name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name;
-      mutable_flag = lbl.lbl_mut;
-    }
-
-let fld_record_set (lbl : label) =
-  Lambda.Fld_record_set
-    (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name)
-
-let blk_record (fields : (label * _) array) mut record_repr =
-  let all_labels_info =
-    Ext_array.map fields (fun (lbl, _) ->
-        Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name)
-  in
-  Lambda.Blk_record
-    { fields = all_labels_info; mutable_flag = mut; record_repr }
-
-let blk_record_inlined fields name num_nonconst optional_labels ~tag ~attrs mutable_flag =
-  let fields =
-    Array.map
-      (fun ((lbl : label), _) ->
-        Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name)
-      fields
-  in
-  Lambda.Blk_record_inlined {fields; name; num_nonconst; tag; mutable_flag; optional_labels; attrs }
-
 let check_bs_attributes_inclusion (attrs1 : Parsetree.attributes)
     (attrs2 : Parsetree.attributes) lbl_name =
   let a = Ext_list.find_def attrs1 find_name lbl_name in

jscomp/ml/lambda.ml

@@ -86,21 +86,47 @@ let mutable_flag_of_tag_info (tag : tag_info) =
   | Blk_some 
    -> Immutable
 
+type label = Types.label_description
+
+let find_name (attr : Parsetree.attribute) =
+  match attr with
+  | ( { txt = "bs.as" | "as" },
+      PStr
+        [
+          {
+            pstr_desc =
+              Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string (s, _)) }, _);
+          };
+        ] ) ->
+      Some s
+  | _ -> None
+     
+let blk_record (fields : (label * _) array) mut record_repr =
+  let all_labels_info =
+    Ext_array.map fields (fun (lbl, _) ->
+        Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name)
+  in
+  Blk_record
+    { fields = all_labels_info; mutable_flag = mut; record_repr }
 
-let blk_record = ref (fun _ _ _ -> 
-  assert false
-  )
-
-
-let blk_record_ext =  ref (fun fields mutable_flag -> 
-    let all_labels_info = fields |> Array.map (fun (x,_) -> x.Types.lbl_name) in    
-    Blk_record_ext {fields = all_labels_info; mutable_flag }
-  )
 
-let blk_record_inlined = ref (fun fields name num_nonconst optional_labels ~tag ~attrs mutable_flag -> 
-  let fields = fields |> Array.map (fun (x,_) -> x.Types.lbl_name) in    
+let blk_record_ext fields mutable_flag =
+  let all_labels_info =
+    Array.map
+      (fun ((lbl : label), _) ->
+        Ext_list.find_def lbl.Types.lbl_attributes find_name lbl.lbl_name)
+      fields
+  in
+  Blk_record_ext {fields = all_labels_info; mutable_flag }
+
+let blk_record_inlined fields name num_nonconst optional_labels ~tag ~attrs mutable_flag =
+  let fields =
+    Array.map
+      (fun ((lbl : label), _) ->
+        Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name)
+      fields
+  in
   Blk_record_inlined {fields; name; num_nonconst; tag; mutable_flag; optional_labels; attrs }
-) 
 
 let ref_tag_info : tag_info = 
   Blk_record {fields = [| "contents" |]; mutable_flag = Mutable; record_repr = Record_regular}
@@ -117,9 +143,17 @@ type field_dbg_info =
   | Fld_variant
   | Fld_cons 
   | Fld_array
-  
-let fld_record = ref (fun (lbl : Types.label_description) ->
-  Fld_record {name = lbl.lbl_name; mutable_flag = Mutable})
+
+let fld_record (lbl : label) =
+  Fld_record
+    {
+      name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name;
+      mutable_flag = lbl.lbl_mut;
+    }
+
+let fld_record_extension (lbl : label) =
+  Fld_record_extension
+    { name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name }
 
 let ref_field_info : field_dbg_info = 
   Fld_record { name = "contents"; mutable_flag = Mutable}
@@ -131,8 +165,21 @@ type set_field_dbg_info =
     | Fld_record_extension_set of string
 
 let ref_field_set_info : set_field_dbg_info = Fld_record_set "contents"    
-let fld_record_set = ref ( fun (lbl : Types.label_description) ->
-  Fld_record_set lbl.lbl_name  )
+let fld_record_set (lbl : label) =
+  Fld_record_set
+    (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name)
+
+let fld_record_inline (lbl : label) =
+  Fld_record_inline
+    { name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name }
+
+let fld_record_inline_set (lbl : label) =
+  Fld_record_inline_set
+    (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name)
+
+let fld_record_extension_set (lbl : label) =
+  Fld_record_extension_set
+    (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name)
 
 type immediate_or_pointer =
   | Immediate

jscomp/ml/lambda.mli

@@ -63,34 +63,34 @@ type tag_info =
   | Blk_record_ext of {fields : string array; mutable_flag : mutable_flag}
   | Blk_lazy_general    
 
+val find_name :
+  Parsetree.attribute -> Asttypes.label option
+
 val tag_of_tag_info : tag_info -> int 
 val mutable_flag_of_tag_info : tag_info -> mutable_flag 
-val blk_record : 
-  ( 
-    (Types.label_description* Typedtree.record_label_definition) array ->
-    mutable_flag -> 
-    record_repr -> 
-    tag_info
-  ) ref
+val blk_record :    
+  (Types.label_description* Typedtree.record_label_definition) array ->
+  mutable_flag -> 
+  record_repr -> 
+  tag_info
+  
 
 val blk_record_ext :
-  ( 
-    (Types.label_description* Typedtree.record_label_definition) array ->
-    mutable_flag -> 
-    tag_info
-  ) ref
+  (Types.label_description* Typedtree.record_label_definition) array ->
+  mutable_flag -> 
+  tag_info
+
 
 val blk_record_inlined :   
-  ( 
-    (Types.label_description* Typedtree.record_label_definition) array ->
-    string ->
-    int ->
-    string list ->
-    tag:int ->
-    attrs:Parsetree.attributes ->
-    mutable_flag ->  
-    tag_info
-  ) ref
+  (Types.label_description* Typedtree.record_label_definition) array ->
+  string ->
+  int ->
+  string list ->
+  tag:int ->
+  attrs:Parsetree.attributes ->
+  mutable_flag ->  
+  tag_info
+
 
 
 
@@ -110,8 +110,16 @@ type field_dbg_info =
   | Fld_array
 
 val fld_record :
-  (Types.label_description -> 
-  field_dbg_info) ref
+  Types.label_description -> 
+  field_dbg_info
+
+val fld_record_inline :
+  Types.label_description -> 
+  field_dbg_info
+
+val fld_record_extension :
+  Types.label_description -> 
+  field_dbg_info
 
 val ref_field_info : field_dbg_info   
 
@@ -125,8 +133,16 @@ type set_field_dbg_info =
 val ref_field_set_info : set_field_dbg_info    
 
 val fld_record_set : 
-  (Types.label_description ->
-  set_field_dbg_info) ref
+  Types.label_description ->
+  set_field_dbg_info
+
+val fld_record_inline_set : 
+  Types.label_description ->
+  set_field_dbg_info
+
+val fld_record_extension_set :
+  Types.label_description -> 
+  set_field_dbg_info
 
 type immediate_or_pointer =
   | Immediate

jscomp/ml/matching.ml

@@ -26,19 +26,6 @@ open Printf
 
 let dbg = false
 
-let find_name (attr : Parsetree.attribute) =
-  match attr with
-  | ( { txt = "bs.as" | "as" },
-      PStr
-        [
-          {
-            pstr_desc =
-              Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string (s, _)) }, _);
-          };
-        ] ) ->
-      Some s
-  | _ -> None
-
 (*  See Peyton-Jones, ``The Implementation of functional programming
     languages'', chapter 5. *)
 (*
@@ -1612,12 +1599,11 @@ let make_record_matching loc all_labels def = function
             match lbl.lbl_repres with
             | Record_float_unused -> assert false
             | Record_regular | Record_optional_labels _ -> 
-              Lprim (Pfield (lbl.lbl_pos, !Lambda.fld_record lbl), [arg], loc) 
+              Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc) 
             | Record_inlined _ ->
-              let name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name in
-              Lprim (Pfield (lbl.lbl_pos, Fld_record_inline {name}), [arg], loc)
+              Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [arg], loc)
             | Record_unboxed _ -> arg
-            | Record_extension -> Lprim (Pfield (lbl.lbl_pos + 1, Fld_record_extension {name = lbl.lbl_name}), [arg], loc) 
+            | Record_extension -> Lprim (Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), [arg], loc) 
           in
           let str =
             match lbl.lbl_mut with

jscomp/ml/matching.mli

@@ -18,9 +18,6 @@
 open Typedtree
 open Lambda
 
-val find_name :
-  Parsetree.attribute -> Asttypes.label option
-
 val call_switcher_variant_constant : 
   (Location.t ->
    Lambda.lambda option ->