AST cleanup: explicit representation for optional record fields in types.

cristianoc · cristianoc · commit 6a30fa275843 · 2024-12-04T15:20:53.000+01:00
diff --git a/analysis/src/ProcessCmt.ml b/analysis/src/ProcessCmt.ml
@@ -20,14 +20,14 @@ let attrsToDocstring attrs =
   | None -> []
   | Some docstring -> [docstring]
 
-let mapRecordField {Types.ld_id; ld_type; ld_attributes} =
+let mapRecordField {Types.ld_id; ld_type; ld_attributes; ld_optional} =
   let astamp = Ident.binding_time ld_id in
   let name = Ident.name ld_id in
   {
     stamp = astamp;
     fname = Location.mknoloc name;
     typ = ld_type;
-    optional = Res_parsetree_viewer.has_optional_attribute ld_attributes;
+    optional = ld_optional;
     docstring =
       (match ProcessAttributes.findDocAttribute ld_attributes with
       | None -> []
@@ -259,10 +259,7 @@ let forTypeDeclaration ~env ~(exported : Exported.t)
                                           stamp = astamp;
                                           fname = Location.mknoloc name;
                                           typ = f.ld_type.ctyp_type;
-                                          optional =
-                                            Res_parsetree_viewer
-                                            .has_optional_attribute
-                                              f.ld_attributes;
+                                          optional = f.ld_optional;
                                           docstring =
                                             (match
                                                ProcessAttributes
@@ -300,16 +297,15 @@ let forTypeDeclaration ~env ~(exported : Exported.t)
                          ld_name = fname;
                          ld_type = {ctyp_type};
                          ld_attributes;
+                         ld_optional;
                        }
                      ->
                        let fstamp = Ident.binding_time ld_id in
                        {
                          stamp = fstamp;
                          fname;
                          typ = ctyp_type;
-                         optional =
-                           Res_parsetree_viewer.has_optional_attribute
-                             ld_attributes;
+                         optional = ld_optional;
                          docstring = attrsToDocstring ld_attributes;
                          deprecated =
                            ProcessAttributes.findDeprecatedAttribute
diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml
@@ -500,9 +500,17 @@ let default_mapper =
           ~loc:(this.location this pcd_loc)
           ~attrs:(this.attributes this pcd_attributes));
     label_declaration =
-      (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
+      (fun this
+           {
+             pld_name;
+             pld_type;
+             pld_loc;
+             pld_mutable;
+             pld_optional;
+             pld_attributes;
+           } ->
         Type.field (map_loc this pld_name) (this.typ this pld_type)
-          ~mut:pld_mutable
+          ~mut:pld_mutable ~optional:pld_optional
           ~loc:(this.location this pld_loc)
           ~attrs:(this.attributes this pld_attributes));
     cases = (fun this l -> List.map (this.case this) l);
diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml
@@ -319,10 +319,12 @@ module Type = struct
       pcd_attributes = attrs;
     }
 
-  let field ?(loc = !default_loc) ?(attrs = []) ?(mut = Immutable) name typ =
+  let field ?(loc = !default_loc) ?(attrs = []) ?(mut = Immutable)
+      ?(optional = false) name typ =
     {
       pld_name = name;
       pld_mutable = mut;
+      pld_optional = optional;
       pld_type = typ;
       pld_loc = loc;
       pld_attributes = attrs;
diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli
@@ -241,6 +241,7 @@ module Type : sig
     ?loc:loc ->
     ?attrs:attrs ->
     ?mut:mutable_flag ->
+    ?optional:bool ->
     str ->
     core_type ->
     label_declaration
diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml
@@ -448,9 +448,17 @@ let default_mapper =
           ~loc:(this.location this pcd_loc)
           ~attrs:(this.attributes this pcd_attributes));
     label_declaration =
-      (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
+      (fun this
+           {
+             pld_name;
+             pld_type;
+             pld_loc;
+             pld_mutable;
+             pld_optional;
+             pld_attributes;
+           } ->
         Type.field (map_loc this pld_name) (this.typ this pld_type)
-          ~mut:pld_mutable
+          ~mut:pld_mutable ~optional:pld_optional
           ~loc:(this.location this pld_loc)
           ~attrs:(this.attributes this pld_attributes));
     cases = (fun this l -> List.map (this.case this) l);
diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml
@@ -459,10 +459,13 @@ let default_mapper =
           ~attrs:(this.attributes this pcd_attributes));
     label_declaration =
       (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
+        let optional, attrs =
+          Parsetree0.get_optional_attr (this.attributes this pld_attributes)
+        in
         Type.field (map_loc this pld_name) (this.typ this pld_type)
-          ~mut:pld_mutable
+          ~mut:pld_mutable ~optional
           ~loc:(this.location this pld_loc)
-          ~attrs:(this.attributes this pld_attributes));
+          ~attrs);
     cases = (fun this l -> List.map (this.case this) l);
     case =
       (fun this {pc_lhs; pc_guard; pc_rhs} ->
diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml
@@ -455,11 +455,21 @@ let default_mapper =
           ~loc:(this.location this pcd_loc)
           ~attrs:(this.attributes this pcd_attributes));
     label_declaration =
-      (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
+      (fun this
+           {
+             pld_name;
+             pld_type;
+             pld_loc;
+             pld_mutable;
+             pld_optional;
+             pld_attributes;
+           } ->
         Type.field (map_loc this pld_name) (this.typ this pld_type)
           ~mut:pld_mutable
           ~loc:(this.location this pld_loc)
-          ~attrs:(this.attributes this pld_attributes));
+          ~attrs:
+            (Parsetree0.add_optional_attr ~optional:pld_optional
+               (this.attributes this pld_attributes)));
     cases = (fun this l -> List.map (this.case this) l);
     case =
       (fun this {pc_lhs; pc_guard; pc_rhs} ->
diff --git a/compiler/ml/datarepr.ml b/compiler/ml/datarepr.ml
@@ -107,9 +107,6 @@ let constructor_descrs ty_path decl cstrs =
       if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts;
       if cd_res = None then incr num_normal)
     cstrs;
-  let has_optional attrs =
-    Ext_list.exists attrs (fun ({txt}, _) -> txt = "res.optional")
-  in
   let rec describe_constructors idx_const idx_nonconst = function
     | [] -> []
     | {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem ->
@@ -135,8 +132,8 @@ let constructor_descrs ty_path decl cstrs =
         match cd_args with
         | Cstr_tuple _ -> []
         | Cstr_record lbls ->
-          Ext_list.filter_map lbls (fun {ld_id; ld_attributes; _} ->
-              if has_optional ld_attributes then Some ld_id.name else None)
+          Ext_list.filter_map lbls (fun {ld_id; ld_optional} ->
+              if ld_optional then Some ld_id.name else None)
       in
       let existentials, cstr_args, cstr_inlined =
         let representation =
diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml
@@ -368,6 +368,7 @@ and type_kind =
 and label_declaration = {
   pld_name: string loc;
   pld_mutable: mutable_flag;
+  pld_optional: bool;
   pld_type: core_type;
   pld_loc: Location.t;
   pld_attributes: attributes; (* l : T [@id1] [@id2] *)
diff --git a/compiler/ml/parsetree0.ml b/compiler/ml/parsetree0.ml
@@ -596,3 +596,17 @@ and module_binding = {
   pmb_loc: Location.t;
 }
 (* X = ME *)
+
+let optional_attr = (Location.mknoloc "res.optional", Parsetree.PStr [])
+let optional_attr0 = (Location.mknoloc "res.optional", PStr [])
+
+let add_optional_attr ~optional attrs =
+  if optional then optional_attr0 :: attrs else attrs
+
+let get_optional_attr attrs_ =
+  let remove_optional_attr attrs =
+    List.filter (fun a -> a <> optional_attr) attrs
+  in
+  let attrs = remove_optional_attr attrs_ in
+  let optional = List.length attrs <> List.length attrs_ in
+  (optional, attrs)
diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml
@@ -209,6 +209,10 @@ let mutable_flag f = function
   | Immutable -> ()
   | Mutable -> pp f "mutable@;"
 
+let optional_flag f = function
+  | false -> ()
+  | true -> pp f "?"
+
 (* trailing space added *)
 let rec_flag f rf =
   match rf with
@@ -1137,9 +1141,10 @@ and type_def_list ctxt f (rf, l) =
 
 and record_declaration ctxt f lbls =
   let type_record_field f pld =
-    pp f "@[<2>%a%s:@;%a@;%a@]"
+    pp f "@[<2>%a%s%a:@;%a@;%a@]"
       mutable_flag pld.pld_mutable
       pld.pld_name.txt
+      optional_flag pld.pld_optional
       (core_type ctxt) pld.pld_type
       (attributes ctxt) pld.pld_attributes
   in
diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml
@@ -309,13 +309,10 @@ let common_initial_env add_type add_extension empty_env =
           ( [
               {
                 ld_id = ident_dict_magic_field_name;
-                ld_attributes =
-                  [
-                    (Location.mknoloc "res.optional", Parsetree.PStr []);
-                    Dict_type_helpers.dict_magic_field_attr;
-                  ];
+                ld_attributes = [Dict_type_helpers.dict_magic_field_attr];
                 ld_loc = Location.none;
                 ld_mutable = Immutable;
+                ld_optional = true;
                 ld_type = newgenty (Tconstr (path_option, [tvar], ref Mnil));
               };
             ],
diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml
@@ -923,11 +923,7 @@ and tree_of_constructor cd =
     (name, args, Some ret, repr)
 
 and tree_of_label l =
-  let opt =
-    l.ld_attributes
-    |> List.exists (fun ({txt}, _) ->
-           txt = "ns.optional" || txt = "res.optional")
-  in
+  let opt = l.ld_optional in
   let typ =
     match l.ld_type.desc with
     | Tconstr (p, [t1], _) when opt && Path.same p Predef.path_option -> t1
diff --git a/compiler/ml/subst.ml b/compiler/ml/subst.ml
@@ -251,6 +251,7 @@ let label_declaration s l =
   {
     ld_id = l.ld_id;
     ld_mutable = l.ld_mutable;
+    ld_optional = l.ld_optional;
     ld_type = typexp s l.ld_type;
     ld_loc = loc s l.ld_loc;
     ld_attributes = attrs s l.ld_attributes;
diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml
@@ -213,6 +213,7 @@ let transl_labels ?record_name env closed lbls =
       {
         pld_name = name;
         pld_mutable = mut;
+        pld_optional = optional;
         pld_type = arg;
         pld_loc = loc;
         pld_attributes = attrs;
@@ -224,6 +225,7 @@ let transl_labels ?record_name env closed lbls =
           ld_id = Ident.create name.txt;
           ld_name = name;
           ld_mutable = mut;
+          ld_optional = optional;
           ld_type = cty;
           ld_loc = loc;
           ld_attributes = attrs;
@@ -242,6 +244,7 @@ let transl_labels ?record_name env closed lbls =
         {
           Types.ld_id = ld.ld_id;
           ld_mutable = ld.ld_mutable;
+          ld_optional = ld.ld_optional;
           ld_type = ty;
           ld_loc = ld.ld_loc;
           ld_attributes = ld.ld_attributes;
@@ -365,9 +368,6 @@ let transl_declaration ~type_record_as_object env sdecl id =
          | [] -> ()
          | (_, _, loc) :: _ ->
            Location.prerr_warning loc Warnings.Constraint_on_gadt);
-      let has_optional attrs =
-        Ext_list.exists attrs (fun ({txt}, _) -> txt = "res.optional")
-      in
       let scstrs =
         Ext_list.map scstrs (fun ({pcd_args} as cstr) ->
             match pcd_args with
@@ -378,7 +378,7 @@ let transl_declaration ~type_record_as_object env sdecl id =
                 pcd_args =
                   Pcstr_record
                     (Ext_list.map lds (fun ld ->
-                         if has_optional ld.pld_attributes then
+                         if ld.pld_optional then
                            let typ = ld.pld_type in
                            let typ =
                              {
@@ -475,6 +475,7 @@ let transl_declaration ~type_record_as_object env sdecl id =
                                  ld_name =
                                    Location.mkloc (Ident.name l.ld_id) l.ld_loc;
                                  ld_mutable = l.ld_mutable;
+                                 ld_optional = l.ld_optional;
                                  ld_type =
                                    {
                                      ctyp_desc = Ttyp_any;
@@ -531,21 +532,17 @@ let transl_declaration ~type_record_as_object env sdecl id =
       Ast_untagged_variants.check_well_formed ~env ~is_untagged_def cstrs;
       (Ttype_variant tcstrs, Type_variant cstrs, sdecl)
     | Ptype_record lbls_ -> (
-      let has_optional attrs =
-        Ext_list.exists attrs (fun ({txt}, _) -> txt = "res.optional")
-      in
       let optional_labels =
         Ext_list.filter_map lbls_ (fun lbl ->
-            if has_optional lbl.pld_attributes then Some lbl.pld_name.txt
-            else None)
+            if lbl.pld_optional then Some lbl.pld_name.txt else None)
       in
       let lbls =
         if optional_labels = [] then lbls_
         else
           Ext_list.map lbls_ (fun lbl ->
               let typ = lbl.pld_type in
               let typ =
-                if has_optional lbl.pld_attributes then
+                if lbl.pld_optional then
                   {
                     typ with
                     ptyp_desc =
@@ -575,6 +572,7 @@ let transl_declaration ~type_record_as_object env sdecl id =
               ld_id = l.ld_id;
               ld_name = {txt = Ident.name l.ld_id; loc = l.ld_loc};
               ld_mutable = l.ld_mutable;
+              ld_optional = l.ld_optional;
               ld_type =
                 {
                   ld_type with
@@ -634,8 +632,7 @@ let transl_declaration ~type_record_as_object env sdecl id =
         check_duplicates sdecl.ptype_loc lbls StringSet.empty;
         let optional_labels =
           Ext_list.filter_map lbls (fun lbl ->
-              if has_optional lbl.ld_attributes then Some lbl.ld_name.txt
-              else None)
+              if lbl.ld_optional then Some lbl.ld_name.txt else None)
         in
         ( Ttype_record lbls,
           Type_record
diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml
@@ -365,6 +365,7 @@ and label_declaration = {
   ld_id: Ident.t;
   ld_name: string loc;
   ld_mutable: mutable_flag;
+  ld_optional: bool;
   ld_type: core_type;
   ld_loc: Location.t;
   ld_attributes: attribute list;
diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli
@@ -471,6 +471,7 @@ and label_declaration = {
   ld_id: Ident.t;
   ld_name: string loc;
   ld_mutable: mutable_flag;
+  ld_optional: bool;
   ld_type: core_type;
   ld_loc: Location.t;
   ld_attributes: attributes;
diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml
@@ -162,6 +162,7 @@ and record_representation =
 and label_declaration = {
   ld_id: Ident.t;
   ld_mutable: mutable_flag;
+  ld_optional: bool;
   ld_type: type_expr;
   ld_loc: Location.t;
   ld_attributes: Parsetree.attributes;
diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli
@@ -290,6 +290,7 @@ and record_representation =
 and label_declaration = {
   ld_id: Ident.t;
   ld_mutable: mutable_flag;
+  ld_optional: bool;
   ld_type: type_expr;
   ld_loc: Location.t;
   ld_attributes: Parsetree.attributes;
diff --git a/compiler/ml/untypeast.ml b/compiler/ml/untypeast.ml
@@ -199,8 +199,8 @@ let constructor_declaration sub cd =
 let label_declaration sub ld =
   let loc = sub.location sub ld.ld_loc in
   let attrs = sub.attributes sub ld.ld_attributes in
-  Type.field ~loc ~attrs ~mut:ld.ld_mutable (map_loc sub ld.ld_name)
-    (sub.typ sub ld.ld_type)
+  Type.field ~loc ~attrs ~mut:ld.ld_mutable ~optional:ld.ld_optional
+    (map_loc sub ld.ld_name) (sub.typ sub ld.ld_type)
 
 let type_extension sub tyext =
   let attrs = sub.attributes sub tyext.tyext_attributes in
diff --git a/compiler/ml/variant_type_spread.ml b/compiler/ml/variant_type_spread.ml
diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml
diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml
diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml
diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/record.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/record.res.txt
diff --git a/tests/syntax_tests/data/parsing/grammar/pattern/expected/dict.res.txt b/tests/syntax_tests/data/parsing/grammar/pattern/expected/dict.res.txt
diff --git a/tests/syntax_tests/data/printer/expr/record.res b/tests/syntax_tests/data/printer/expr/record.res
diff --git a/tests/tools_tests/ppx/TestPpx.res b/tests/tools_tests/ppx/TestPpx.res
diff --git a/tests/tools_tests/src/expected/TestPpx.res.jsout b/tests/tools_tests/src/expected/TestPpx.res.jsout

Original file line number	Diff line number	Diff line change
`@@ -319,10 +319,12 @@ module Type = struct`
`319`	`319`	`pcd_attributes = attrs;`
`320`	`320`	`}`
`321`	`321`
`322`		`- let field ?(loc = !default_loc) ?(attrs = []) ?(mut = Immutable) name typ =`
	`322`	`+ let field ?(loc = !default_loc) ?(attrs = []) ?(mut = Immutable)`
	`323`	`+ ?(optional = false) name typ =`
`323`	`324`	`{`
`324`	`325`	`pld_name = name;`
`325`	`326`	`pld_mutable = mut;`
	`327`	`+ pld_optional = optional;`
`326`	`328`	`pld_type = typ;`
`327`	`329`	`pld_loc = loc;`
`328`	`330`	`pld_attributes = attrs;`
Original file line number	Diff line number	Diff line change
`@@ -251,6 +251,7 @@ let label_declaration s l =`
`251`	`251`	`{`
`252`	`252`	`ld_id = l.ld_id;`
`253`	`253`	`ld_mutable = l.ld_mutable;`
	`254`	`+ ld_optional = l.ld_optional;`
`254`	`255`	`ld_type = typexp s l.ld_type;`
`255`	`256`	`ld_loc = loc s l.ld_loc;`
`256`	`257`	`ld_attributes = attrs s l.ld_attributes;`