Pattern matching for dicts

CHANGELOG.md

@@ -21,6 +21,7 @@
 - Use FORCE_COLOR environmental variable to force colorized output https://github.com/rescript-lang/rescript-compiler/pull/7033
 - Allow spreads of variants in patterns (`| ...someVariant as v => `) when the variant spread is a subtype of the variant matched on. https://github.com/rescript-lang/rescript-compiler/pull/6721
 - Fix the issue where dynamic imports are not working for function-defined externals. https://github.com/rescript-lang/rescript-compiler/pull/7060 
+- Allow pattern matching on dicts. `switch someDict { | dict{"one": 1} => Js.log("one is one") }` https://github.com/rescript-lang/rescript-compiler/pull/7059
 
 #### :bug: Bug fix
 

jscomp/build_tests/super_errors/expected/dict_coercion.res.expected

@@ -0,0 +1,10 @@
+
+  We've found a bug for you!
+  /.../fixtures/dict_coercion.res:7:10-30
+
+  5 │ type fakeDict<'t> = {dictValuesType?: 't}
+  6 │ 
+  7 │ let d = (dict :> fakeDict<int>)
+  8 │ 
+
+  Type Js.Dict.t<int> = dict<int> is not a subtype of fakeDict<int>

jscomp/build_tests/super_errors/expected/dict_magic_field_on_non_dict.res.expected

@@ -0,0 +1,13 @@
+
+  We've found a bug for you!
+  /.../fixtures/dict_magic_field_on_non_dict.res:5:6-23
+
+  3 │ let foo = (fakeDict: fakeDict<'a>) => {
+  4 │   switch fakeDict {
+  5 │   | {someUndefinedField: 1} => Js.log("one")
+  6 │   | _ => Js.log("not one")
+  7 │   }
+
+  The field someUndefinedField does not belong to type fakeDict
+
+  This record pattern is expected to have type fakeDict<'a>

jscomp/build_tests/super_errors/expected/dict_pattern_inference.res.expected

@@ -0,0 +1,12 @@
+
+  We've found a bug for you!
+  /.../fixtures/dict_pattern_inference.res:3:27-33
+
+  1 │ let foo = dict =>
+  2 │   switch dict {
+  3 │   | dict{"one": 1, "two": "hello"} => Js.log("one")
+  4 │   | _ => Js.log("not one")
+  5 │   }
+
+  This pattern matches values of type string
+  but a pattern was expected which matches values of type int

jscomp/build_tests/super_errors/expected/dict_pattern_inference_constrained.res.expected

@@ -0,0 +1,17 @@
+
+  We've found a bug for you!
+  /.../fixtures/dict_pattern_inference_constrained.res:4:27-30
+
+  2 ┆ switch dict {
+  3 ┆ | dict{"one": 1} =>
+  4 ┆   let _: dict<string> = dict
+  5 ┆   Js.log("one")
+  6 ┆ | _ => Js.log("not one")
+
+  This has type: dict<int>
+  But it's expected to have type: dict<string>
+
+  The incompatible parts:
+    int vs string
+
+  You can convert int to string with Belt.Int.toString.

jscomp/build_tests/super_errors/expected/dict_pattern_regular_record.res.expected

@@ -0,0 +1,12 @@
+
+  We've found a bug for you!
+  /.../fixtures/dict_pattern_regular_record.res:5:5-22
+
+  3 │ let constrainedAsDict = (dict: x) =>
+  4 │   switch dict {
+  5 │   | dict{"one": "one"} => Js.log("one")
+  6 │   | _ => Js.log("not one")
+  7 │   }
+
+  This pattern matches values of type dict<string>
+  but a pattern was expected which matches values of type x

jscomp/build_tests/super_errors/expected/dict_record_style_field_access.res.expected

@@ -0,0 +1,9 @@
+
+  We've found a bug for you!
+  /.../fixtures/dict_record_style_field_access.res:5:20-23
+
+  3 │ }
+  4 │ 
+  5 │ let x = stringDict.name
+
+  Direct field access on a dict is not supported. Use Dict.get instead.

jscomp/build_tests/super_errors/fixtures/dict_coercion.res

@@ -0,0 +1,7 @@
+let dict = Js.Dict.empty()
+dict->Js.Dict.set("someKey1", 1)
+dict->Js.Dict.set("someKey2", 2)
+
+type fakeDict<'t> = {dictValuesType?: 't}
+
+let d = (dict :> fakeDict<int>)

jscomp/build_tests/super_errors/fixtures/dict_magic_field_on_non_dict.res

@@ -0,0 +1,8 @@
+type fakeDict<'t> = {dictValuesType?: 't}
+
+let foo = (fakeDict: fakeDict<'a>) => {
+  switch fakeDict {
+  | {someUndefinedField: 1} => Js.log("one")
+  | _ => Js.log("not one")
+  }
+}

jscomp/build_tests/super_errors/fixtures/dict_pattern_inference.res

@@ -0,0 +1,5 @@
+let foo = dict =>
+  switch dict {
+  | dict{"one": 1, "two": "hello"} => Js.log("one")
+  | _ => Js.log("not one")
+  }

jscomp/build_tests/super_errors/fixtures/dict_pattern_inference_constrained.res

@@ -0,0 +1,7 @@
+let foo = dict =>
+  switch dict {
+  | dict{"one": 1} =>
+    let _: dict<string> = dict
+    Js.log("one")
+  | _ => Js.log("not one")
+  }

jscomp/build_tests/super_errors/fixtures/dict_pattern_regular_record.res

@@ -0,0 +1,7 @@
+type x = {one: int}
+
+let constrainedAsDict = (dict: x) =>
+  switch dict {
+  | dict{"one": "one"} => Js.log("one")
+  | _ => Js.log("not one")
+  }

jscomp/build_tests/super_errors/fixtures/dict_record_style_field_access.res

@@ -0,0 +1,5 @@
+let stringDict = dict{
+  "name": "hello",
+}
+
+let x = stringDict.name

jscomp/ml/dict_type_helpers.ml

@@ -0,0 +1,48 @@
+(*
+  An overview of the implementation of dicts in ReScript:
+  ### What is a dict?
+  Dicts are effectively an object with unknown fields, but a single known type of the values it holds.
+
+  ### How are they implemented?
+  Dicts in ReScript are implemented as predefined record type, with a single (magic) field that holds 
+  the type of the dict's values. This field is called `dictValuesType`, and is just an implementation
+  detail - it's never actually exposed to the user, just used internally. 
+
+  The compiler will route any label lookup on the dict record type to the magic field, which creates a 
+  record with unknown keys, but of a single type.
+
+  The reason for this seemingly convoluted implementation is that it allows us to piggyback on the 
+  existing record pattern matching mechanism, which means we get pattern matching on dicts for free.
+
+  ### Modifications to the type checker
+  We've made a few smaller modifications to the type checker to support this implementation:
+
+  - We've added a new predefined type `dict` that is a record with a single field called `dictValuesType`.
+    This type is used to represent the type of the values in a dict.
+  - We've modified the type checker to recognize `dict` patterns, and route them to the predefined `dict` type.
+    This allows us to get full inference for dicts in patterns. 
+
+  ### Syntax
+  There's first class syntax support for dicts, both as expressions and as patterns.
+  A dict pattern is treated as a record pattern in the compiler and syntax, with an attriubute `@res.dictPattern`
+  attached to it. This attribute is used to tell the compiler that the pattern is a dict pattern, and is what
+  triggers the compiler to treat the dict record type differently to regular record types.
+  *)
+let dict_magic_field_name = "dictValuesType"
+
+let has_dict_pattern_attribute attrs =
+  attrs
+  |> List.find_opt (fun (({txt}, _) : Parsetree.attribute) ->
+         txt = "res.dictPattern")
+  |> Option.is_some
+
+let has_dict_attribute attrs =
+  attrs
+  |> List.find_opt (fun (({txt}, _) : Parsetree.attribute) -> txt = "res.$dict")
+  |> Option.is_some
+
+let dict_attr : Parsetree.attribute =
+  (Location.mknoloc "res.$dict", Parsetree.PStr [])
+
+let dict_magic_field_attr : Parsetree.attribute =
+  (Location.mknoloc "res.$dictMagicField", Parsetree.PStr [])

jscomp/ml/predef.ml

@@ -112,6 +112,8 @@ and ident_failure = ident_create_predef_exn "Failure"
 and ident_ok = ident_create_predef_exn "Ok"
 and ident_error = ident_create_predef_exn "Error"
 
+and ident_dict_magic_field_name = ident_create Dict_type_helpers.dict_magic_field_name
+
 and ident_js_error = ident_create_predef_exn "JsError"
 and ident_not_found = ident_create_predef_exn "Not_found"
 
@@ -218,10 +220,28 @@ let common_initial_env add_type add_extension empty_env =
      type_variance = [Variance.covariant; Variance.covariant]}
   and decl_dict =
     let tvar = newgenvar() in
+    (* Dicts are implemented as a single "magic" field record. This magic field
+       is the medium through which we can piggy back on the existing record pattern
+       matching mechanism. We do this by letting the compiler route any label lookup
+       for the dict record type to the magic field, which has the type of the values
+       of the dict.
+
+       So, this definition is important for the dict pattern matching functionality, 
+       but not something intended to be exposed to the user. *) 
     {decl_abstr with
+      type_attributes = [Dict_type_helpers.dict_attr];
       type_params = [tvar];
       type_arity = 1;
-      type_variance = [Variance.full]}
+      type_variance = [Variance.full];
+      type_kind = Type_record ([{
+          ld_id = ident_dict_magic_field_name;
+          ld_attributes = [(Location.mknoloc "res.optional", Parsetree.PStr []); Dict_type_helpers.dict_magic_field_attr];
+          ld_loc = Location.none;
+          ld_mutable = Immutable;
+          ld_type = newgenty (Tconstr (path_option, [tvar], ref Mnil));
+        }], 
+        Record_optional_labels [Ident.name ident_dict_magic_field_name]);
+    }
   and decl_uncurried =
     let tvar1, tvar2 = newgenvar(), newgenvar() in
     {decl_abstr with

jscomp/ml/typecore.ml

@@ -75,6 +75,7 @@ type error =
   | Uncurried_arity_mismatch of type_expr * int * int
   | Field_not_optional of string * type_expr
   | Type_params_not_supported of Longident.t
+  | Field_access_on_dict_type
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
 
@@ -788,6 +789,8 @@ module NameChoice(Name : sig
   val get_name: t -> string
   val get_type: t -> type_expr
   val get_descrs: Env.type_descriptions -> t list
+
+  val add_with_name: t -> string -> t
   val unbound_name_error: Env.t -> Longident.t loc -> 'a
 
 end) = struct
@@ -798,10 +801,36 @@ end) = struct
     | Tconstr(p, _, _) -> p
     | _ -> assert false
 
-  let lookup_from_type env tpath lid =
+  let lookup_from_type env tpath (lid : Longident.t loc) : Name.t =
     let descrs = get_descrs (Env.find_type_descrs tpath env) in
     Env.mark_type_used env (Path.last tpath) (Env.find_type tpath env);
-    match lid.txt with
+    let is_dict = Path.same tpath Predef.path_dict in
+    if is_dict then (
+      (* [dict] Dicts are implemented as a record with a single "magic" field. This magic field is 
+         used to track the dict value type, and any label lookup on the dict record type 
+         will give that single value type back. This is how we can piggy back on the record 
+         pattern matching mechanism.
+
+        The code below handles directing any label lookup to the magic field. *)
+      match lid.txt with
+        Longident.Lident s_ -> begin
+          let s = 
+            if List.exists (fun nd -> get_name nd = s_) descrs
+            || not (List.exists (fun nd -> get_name nd = Dict_type_helpers.dict_magic_field_name) descrs)
+            then s_
+            else Dict_type_helpers.dict_magic_field_name in 
+          try
+            let x = List.find (fun nd -> get_name nd = s) descrs in
+            if s = Dict_type_helpers.dict_magic_field_name
+              then add_with_name x s_
+              else x
+          with Not_found ->
+            let names = List.map get_name descrs in
+            raise (Error (lid.loc, env,
+                          Wrong_name ("", newvar (), type_kind, tpath, s, names)))
+        end
+    | _ -> raise Not_found) 
+    else match lid.txt with
       Longident.Lident s -> begin
         try
           List.find (fun nd -> get_name nd = s) descrs
@@ -884,6 +913,20 @@ module Label = NameChoice (struct
   type t = label_description
   let type_kind = "record"
   let get_name lbl = lbl.lbl_name
+
+  let add_with_name lbl name =
+    (* [dict] This is used in dicts and shouldn't be used anywhere else. 
+       It adds a new field to an existing record type, to "fool" the pattern
+       matching into thinking the label exists. *)
+    let l = 
+      {lbl with
+        lbl_name = name;
+        lbl_pos = Array.length lbl.lbl_all;
+        lbl_repres = Record_optional_labels [name]} in
+    let lbl_all_list = Array.to_list lbl.lbl_all @ [l] in
+    let lbl_all = Array.of_list lbl_all_list in
+    Ext_array.iter lbl_all (fun lbl -> lbl.lbl_all <- lbl_all);
+    l
   let get_type lbl = lbl.lbl_res
   let get_descrs = snd
   let unbound_name_error = Typetexp.unbound_label_error
@@ -1040,6 +1083,8 @@ module Constructor = NameChoice (struct
   let type_kind = "variant"
   let get_name cstr = cstr.cstr_name
   let get_type cstr = cstr.cstr_res
+
+  let add_with_name _cstr _name = assert false
   let get_descrs = fst
   let unbound_name_error = Typetexp.unbound_constructor_error
 end)
@@ -1348,12 +1393,20 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
         | _            -> k None
       end
   | Ppat_record(lid_sp_list, closed) ->
-      let opath, record_ty =
+      let has_dict_pattern_attr = Dict_type_helpers.has_dict_pattern_attribute sp.ppat_attributes in
+      let opath, record_ty = (
+      if has_dict_pattern_attr then (
+        (* [dict] If this is a dict pattern match we know we should force the record type
+            as the dict record type with a fresh type variable. This fixes so that dicts
+            can still be inferred properly from just pattern usage. Without this little 
+            tweak, the inference would not work properly. *)
+        (Some (Predef.path_dict, Predef.path_dict), newgenty (Tconstr (Predef.path_dict, [newvar ()], ref Mnil)))
+      ) else
         try
           let (p0, p, _, _) = extract_concrete_record !env expected_ty in
           Some (p0, p), expected_ty
         with Not_found -> None, newvar ()
-      in
+      ) in
       let get_jsx_component_error_info = get_jsx_component_error_info ~extract_concrete_typedecl opath !env record_ty in
       let process_optional_label (ld, pat) =
         let exp_optional_attr = check_optional_attr !env ld pat.ppat_attributes pat.ppat_loc in
@@ -2983,8 +3036,16 @@ and type_label_access env srecord lid =
   let ty_exp = record.exp_type in
   let opath =
     try
-      let (p0, p, _, _) = extract_concrete_record env ty_exp in
-      Some(p0, p)
+      match extract_concrete_typedecl env ty_exp with
+      | (p0, _, {type_attributes}) 
+        when Path.same p0 Predef.path_dict && Dict_type_helpers.has_dict_attribute type_attributes -> 
+          (* [dict] Cover the case when trying to direct field access on a dict, e.g. `someDict.name`.
+            We need to disallow this because the fact that a dict is represented as a single field
+            record internally is just an implementation detail, and not intended to be exposed to
+            the user. *)
+          raise(Error(lid.loc, env, Field_access_on_dict_type))
+      | (p0, p, {type_kind=Type_record _}) -> Some(p0, p)
+      | _ -> None
     with Not_found -> None
   in
   let labels = Typetexp.find_all_labels env lid.loc lid.txt in
@@ -4101,6 +4162,8 @@ let report_error env ppf = function
       type_expr typ
   | Type_params_not_supported lid ->
     fprintf ppf "The type %a@ has type parameters, but type parameters is not supported here." longident lid
+  | Field_access_on_dict_type ->
+    fprintf ppf "Direct field access on a dict is not supported. Use Dict.get instead."
 
 
 let super_report_error_no_wrap_printing_env = report_error

jscomp/ml/typecore.mli

@@ -108,6 +108,7 @@ type error =
   | Uncurried_arity_mismatch of type_expr * int * int
   | Field_not_optional of string * type_expr
   | Type_params_not_supported of Longident.t
+  | Field_access_on_dict_type
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
 

jscomp/ml/types.ml

@@ -303,7 +303,7 @@ type label_description =
     lbl_arg: type_expr;                 (* Type of the argument *)
     lbl_mut: mutable_flag;              (* Is this a mutable field? *)
     lbl_pos: int;                       (* Position in block *)
-    lbl_all: label_description array;   (* All the labels in this type *)
+    mutable lbl_all: label_description array;   (* All the labels in this type *)
     lbl_repres: record_representation;  (* Representation for this record *)
     lbl_private: private_flag;          (* Read-only field? *)
     lbl_loc: Location.t;

jscomp/ml/types.mli

@@ -449,7 +449,7 @@ type label_description =
     lbl_arg: type_expr;                 (* Type of the argument *)
     lbl_mut: mutable_flag;              (* Is this a mutable field? *)
     lbl_pos: int;                       (* Position in block *)
-    lbl_all: label_description array;   (* All the labels in this type *)
+    mutable lbl_all: label_description array;   (* All the labels in this type *)
     lbl_repres: record_representation;  (* Representation for this record *)
     lbl_private: private_flag;          (* Read-only field? *)
     lbl_loc: Location.t;