Experiment with allowing empty inline records (#6494)

zth · cristianoc · web-flow · commit c1b970185a2f · 2023-11-27T10:42:09.000+01:00
* experiment with allowing empty inline records

* remove check for empty record pattern match

* syntax tests

* Update inline_record_test.res

* add extra test for top level empty record match

* changelog

* Remove some dead code.

---------

Co-authored-by: Cristiano Calcagno &lt;cristianoc@users.noreply.github.com&gt;
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -12,6 +12,11 @@
 
 # 11.0.0-rc.7 (Unreleased)
 
+#### :rocket: New Feature
+
+- Allow empty inline records in variants. https://github.com/rescript-lang/rescript-compiler/pull/6494
+- Allow empty record patterns in pattern matching. https://github.com/rescript-lang/rescript-compiler/pull/6494
+
 # 11.0.0-rc.6
 
 #### :rocket: New Feature
diff --git a/jscomp/frontend/bs_ast_invariant.ml b/jscomp/frontend/bs_ast_invariant.ml
@@ -166,9 +166,6 @@ let emit_external_warnings : iterator =
       (fun self (pat : Parsetree.pattern) ->
         match pat.ppat_desc with
         | Ppat_constant constant -> check_constant pat.ppat_loc constant
-        | Ppat_record ([], _) ->
-          Location.raise_errorf ~loc:pat.ppat_loc
-            "Empty record pattern is not supported"
         | _ -> super.pat self pat);
   }
 
diff --git a/jscomp/gentype/GenTypeCommon.ml b/jscomp/gentype/GenTypeCommon.ml
@@ -26,7 +26,7 @@ type labelJS =
   | IntLabel of string
   | StringLabel of string
 
-type case = {label: string; labelJS: labelJS}
+type case = {labelJS: labelJS}
 
 let isJSSafePropertyName name =
   name = ""
diff --git a/jscomp/gentype/Runtime.ml b/jscomp/gentype/Runtime.ml
@@ -1,21 +1,6 @@
-type recordGen = {mutable unboxed: int; mutable boxed: int}
-type recordValue = int
 type moduleItem = string
 type moduleAccessPath = Root of string | Dot of moduleAccessPath * moduleItem
 
-let recordValueToString recordValue = recordValue |> string_of_int
-let recordGen () = {unboxed = 0; boxed = 0}
-
-let newRecordValue ~unboxed recordGen =
-  if unboxed then (
-    let v = recordGen.unboxed in
-    recordGen.unboxed <- recordGen.unboxed + 1;
-    v)
-  else
-    let v = recordGen.boxed in
-    recordGen.boxed <- recordGen.boxed + 1;
-    v
-
 let newModuleItem ~name = name
 
 let rec emitModuleAccessPath ~config moduleAccessPath =
diff --git a/jscomp/gentype/Runtime.mli b/jscomp/gentype/Runtime.mli
@@ -1,7 +1,5 @@
 open GenTypeCommon
 
-type recordGen
-type recordValue
 type moduleItem
 type moduleAccessPath = Root of string | Dot of moduleAccessPath * moduleItem
 
@@ -11,9 +9,6 @@ val emitModuleAccessPath : config:Config.t -> moduleAccessPath -> string
 
 val isMutableObjectField : string -> bool
 val newModuleItem : name:string -> moduleItem
-val newRecordValue : unboxed:bool -> recordGen -> recordValue
-val recordGen : unit -> recordGen
-val recordValueToString : recordValue -> string
 val jsVariantTag : polymorphic:bool -> tag:string option -> string
 val jsVariantPayloadTag : n:int -> string
 val jsVariantValue : polymorphic:bool -> string
diff --git a/jscomp/gentype/TranslateCoreType.ml b/jscomp/gentype/TranslateCoreType.ml
@@ -192,7 +192,7 @@ and translateCoreType_ ~config ~typeVarsGen
                  else if isNumber label then IntLabel label
                  else StringLabel label
                in
-               {label; labelJS})
+               {labelJS})
       in
       let payloadsTranslations =
         payloads
@@ -207,7 +207,6 @@ and translateCoreType_ ~config ~typeVarsGen
                {
                  case =
                    {
-                     label;
                      labelJS =
                        (if isNumber label then IntLabel label
                        else StringLabel label);
diff --git a/jscomp/gentype/TranslateTypeDeclarations.ml b/jscomp/gentype/TranslateTypeDeclarations.ml
@@ -23,7 +23,6 @@ let createExportTypeFromTypeDeclaration ~annotation ~loc ~nameAs ~opaque ~type_
 
 let createCase (label, attributes) ~poly =
   {
-    label;
     labelJS =
       (match
          attributes |> Annotation.getAttributePayload Annotation.tagIsAs
@@ -230,7 +229,6 @@ let traslateDeclarationKind ~config ~loc ~outputFileRelative ~resolver
     }
     |> returnTypeDeclaration
   | VariantDeclarationFromTypes constructorDeclarations, None ->
-    let recordGen = Runtime.recordGen () in
     let variants =
       constructorDeclarations
       |> List.map (fun constructorDeclaration ->
@@ -262,46 +260,25 @@ let traslateDeclarationKind ~config ~loc ~outputFileRelative ~resolver
                |> Translation.translateDependencies ~config ~outputFileRelative
                     ~resolver
              in
-             let recordValue =
-               recordGen
-               |> Runtime.newRecordValue
-                    ~unboxed:(constructorArgs = Cstr_tuple [])
-             in
-             ( name,
-               attributes,
-               argTypes,
-               importTypes,
-               recordValue |> Runtime.recordValueToString ))
+             (name, attributes, argTypes, importTypes))
     in
     let variantsNoPayload, variantsWithPayload =
-      variants |> List.partition (fun (_, _, argTypes, _, _) -> argTypes = [])
+      variants |> List.partition (fun (_, _, argTypes, _) -> argTypes = [])
     in
     let noPayloads =
       variantsNoPayload
-      |> List.map
-           (fun (name, attributes, _argTypes, _importTypes, recordValue) ->
-             {
-               ((name, attributes) |> createCase ~poly:false) with
-               label = recordValue;
-             })
+      |> List.map (fun (name, attributes, _argTypes, _importTypes) ->
+             (name, attributes) |> createCase ~poly:false)
     in
     let payloads =
       variantsWithPayload
-      |> List.map
-           (fun (name, attributes, argTypes, _importTypes, recordValue) ->
+      |> List.map (fun (name, attributes, argTypes, _importTypes) ->
              let type_ =
                match argTypes with
                | [type_] -> type_
                | _ -> Tuple argTypes
              in
-             {
-               case =
-                 {
-                   ((name, attributes) |> createCase ~poly:false) with
-                   label = recordValue;
-                 };
-               t = type_;
-             })
+             {case = (name, attributes) |> createCase ~poly:false; t = type_})
     in
     let variantTyp =
       createVariant ~inherits:[] ~noPayloads ~payloads ~polymorphic:false
@@ -325,7 +302,7 @@ let traslateDeclarationKind ~config ~loc ~outputFileRelative ~resolver
     in
     let importTypes =
       variants
-      |> List.map (fun (_, _, _, importTypes, _) -> importTypes)
+      |> List.map (fun (_, _, _, importTypes) -> importTypes)
       |> List.concat
     in
     {CodeItem.exportFromTypeDeclaration; importTypes} |> returnTypeDeclaration
diff --git a/jscomp/gentype/TranslateTypeExprFromTypes.ml b/jscomp/gentype/TranslateTypeExprFromTypes.ml
@@ -137,15 +137,13 @@ let translateConstr ~config ~paramsTranslation ~(path : Path.t) ~typeEnv =
     }
   | ( (["Pervasives"; "result"] | ["Belt"; "Result"; "t"] | ["result"]),
       [paramTranslation1; paramTranslation2] ) ->
-    let case n name type_ =
-      {case = {label = string_of_int n; labelJS = StringLabel name}; t = type_}
-    in
+    let case name type_ = {case = {labelJS = StringLabel name}; t = type_} in
     let variant =
       createVariant ~inherits:[] ~noPayloads:[]
         ~payloads:
           [
-            case 0 "Ok" paramTranslation1.type_;
-            case 1 "Error" paramTranslation2.type_;
+            case "Ok" paramTranslation1.type_;
+            case "Error" paramTranslation2.type_;
           ]
         ~polymorphic:false ~tag:None ~unboxed:false
     in
@@ -384,7 +382,6 @@ and translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv
         noPayloads
         |> List.map (fun label ->
                {
-                 label;
                  labelJS =
                    (if isNumber label then IntLabel label
                    else StringLabel label);
@@ -401,8 +398,7 @@ and translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv
       t |> translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv
     | {noPayloads; payloads; unknowns = []} ->
       let noPayloads =
-        noPayloads
-        |> List.map (fun label -> {label; labelJS = StringLabel label})
+        noPayloads |> List.map (fun label -> {labelJS = StringLabel label})
       in
       let payloadTranslations =
         payloads
@@ -414,10 +410,7 @@ and translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv
       let payloads =
         payloadTranslations
         |> List.map (fun (label, translation) ->
-               {
-                 case = {label; labelJS = StringLabel label};
-                 t = translation.type_;
-               })
+               {case = {labelJS = StringLabel label}; t = translation.type_})
       in
       let type_ =
         createVariant ~inherits:[] ~noPayloads ~payloads ~polymorphic:true
diff --git a/jscomp/gentype_tests/typescript-react-example/package-lock.json b/jscomp/gentype_tests/typescript-react-example/package-lock.json
diff --git a/jscomp/ml/typecore.ml b/jscomp/ml/typecore.ml
@@ -1273,7 +1273,6 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
         | _            -> k None
       end
   | Ppat_record(lid_sp_list, closed) ->
-      assert (lid_sp_list <> []);
       let opath, record_ty =
         try
           let (p0, p, _, _) = extract_concrete_record !env expected_ty in
diff --git a/jscomp/syntax/src/res_core.ml b/jscomp/syntax/src/res_core.ml
@@ -4544,7 +4544,6 @@ and parseConstrDeclArgs p =
       (* TODO: this could use some cleanup/stratification *)
       match p.Parser.token with
       | Lbrace -> (
-        let lbrace = p.startPos in
         Parser.next p;
         let startPos = p.Parser.startPos in
         match p.Parser.token with
@@ -4683,14 +4682,6 @@ and parseConstrDeclArgs p =
                 :: parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations
                      ~closing:Rbrace ~f:parseFieldDeclarationRegion p
             in
-            let () =
-              match fields with
-              | [] ->
-                Parser.err ~startPos:lbrace p
-                  (Diagnostics.message
-                     "An inline record declaration needs at least one field")
-              | _ -> ()
-            in
             Parser.expect Rbrace p;
             Parser.optional p Comma |> ignore;
             Parser.expect Rparen p;
diff --git a/jscomp/syntax/tests/parsing/errors/typeDef/expected/emptyInlineRecord.res.txt b/jscomp/syntax/tests/parsing/errors/typeDef/expected/emptyInlineRecord.res.txt
@@ -1,14 +1,3 @@
-
-  Syntax error!
-  tests/parsing/errors/typeDef/emptyInlineRecord.res:3:10-11
-
-  1 │ type node<'a> =
-  2 │   | Nil
-  3 │   | Node({})
-  4 │ 
-
-  An inline record declaration needs at least one field
-
 type nonrec 'a node =
   | Nil 
   | Node of {
diff --git a/jscomp/test/inline_record_test.js b/jscomp/test/inline_record_test.js
diff --git a/jscomp/test/inline_record_test.res b/jscomp/test/inline_record_test.res
@@ -117,3 +117,20 @@ let ff1 = (x: t1): t1 =>
   }
 
 let () = Mt.from_pair_suites(__MODULE__, suites.contents)
+
+type emptyRecord = A | B({})
+
+let b = B({})
+
+let () = switch b {
+| A => Js.log("A!")
+| B({}) => Js.log("B")
+}
+
+type r = {y: int}
+let r = {y: 10}
+
+switch r {
+| {y: 10} => Js.log("10!")
+| {} => Js.log("Catch all?")
+}

Original file line number	Diff line number	Diff line change
`@@ -166,9 +166,6 @@ let emit_external_warnings : iterator =`
`166`	`166`	`(fun self (pat : Parsetree.pattern) ->`
`167`	`167`	`match pat.ppat_desc with`
`168`	`168`	`\| Ppat_constant constant -> check_constant pat.ppat_loc constant`
`169`		`- \| Ppat_record ([], _) ->`
`170`		`- Location.raise_errorf ~loc:pat.ppat_loc`
`171`		`- "Empty record pattern is not supported"`
`172`	`169`	`\| _ -> super.pat self pat);`
`173`	`170`	`}`
`174`	`171`