Type spreads of regular variants in patterns (#6721)

* poc of type spreads of regular variants in patterns

* cleanup

* fix subtype error messages and add fixtures

* changelog

* refactor to handle type params (not supported)

* refactor

* add failing test

* accidental reformat

* snake_case

* wip attempt

* change approach to expanding variant spread in the parsetree instead of typedtree

* cleanup unneeded changes

* disable unused subpattern warning when constructors is from variant pattern spread

* update error

* cleanup

* change to use Ppat_type as transfer mechanism for variant spreads instead of Ppat_var

* formatting

* add example with payloads

Author: zth

CHANGELOG.md

@@ -15,6 +15,7 @@
 #### :rocket: New Feature
 
 - 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
 
 #### :bug: Bug fix
 

jscomp/build_tests/super_errors/expected/variant_pattern_type_spreads_not_subtype.res.expected

@@ -0,0 +1,11 @@
+
+  We've found a bug for you!
+  /.../fixtures/variant_pattern_type_spreads_not_subtype.res:7:8
+
+  5 │ let lookup = (b: b) =>
+  6 │   switch b {
+  7 │   | ...c as c => Js.log(c)
+  8 │   | Four => Js.log("four")
+  9 │   | Five => Js.log("five")
+
+  Type c is not a subtype of b

jscomp/build_tests/super_errors/expected/variant_pattern_type_spreads_not_variant.res.expected

@@ -0,0 +1,12 @@
+
+  We've found a bug for you!
+  /.../fixtures/variant_pattern_type_spreads_not_variant.res:7:8
+
+  5 │ let lookup = (b: b) =>
+  6 │   switch b {
+  7 │   | ...c as c => Js.log(c)
+  8 │   | Four => Js.log("four")
+  9 │   | Five => Js.log("five")
+
+  The type c
+is not a variant type

jscomp/build_tests/super_errors/fixtures/variant_pattern_type_spreads_not_subtype.res

@@ -0,0 +1,10 @@
+type a = One | Two | Three
+type b = | ...a | Four | Five
+type c = Six | Seven
+
+let lookup = (b: b) =>
+  switch b {
+  | ...c as c => Js.log(c)
+  | Four => Js.log("four")
+  | Five => Js.log("five")
+  }

jscomp/build_tests/super_errors/fixtures/variant_pattern_type_spreads_not_variant.res

@@ -0,0 +1,10 @@
+type a = One | Two | Three
+type b = | ...a | Four | Five
+type c = {name: string}
+
+let lookup = (b: b) =>
+  switch b {
+  | ...c as c => Js.log(c)
+  | Four => Js.log("four")
+  | Five => Js.log("five")
+  }

jscomp/ml/parmatch.ml

@@ -2259,11 +2259,13 @@ let check_unused pred casel =
                   Location.prerr_warning
                     q.pat_loc Warnings.Unused_match
               | Upartial ps ->
-                  List.iter
+                  ps
+                  |> List.filter (fun p -> 
+                    not (Variant_type_spread.is_pat_from_variant_spread_attr p))
+                  |> List.iter
                     (fun p ->
                       Location.prerr_warning
                         p.pat_loc Warnings.Unused_pat)
-                    ps
               | Used -> ()
             with Empty | Not_found | NoGuard -> assert false
             end ;

jscomp/ml/typecore.ml

@@ -74,6 +74,7 @@ type error =
   | Empty_record_literal
   | Uncurried_arity_mismatch of type_expr * int * int
   | Field_not_optional of string * type_expr
+  | Type_params_not_supported of Longident.t
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
 
@@ -595,6 +596,61 @@ let build_or_pat env loc lid =
           pat pats in
       (path, rp { r with pat_loc = loc },ty)
 
+let extract_type_from_pat_variant_spread env lid expected_ty =
+  let path, decl = Typetexp.find_type env lid.loc lid.txt in
+  match decl with
+  | {type_kind = Type_variant constructors; type_params} -> (
+    if List.length type_params > 0 then raise (Error (lid.loc, env, Type_params_not_supported lid.txt));
+    let ty = newgenty (Tconstr (path, [], ref Mnil)) in
+    (try 
+        Ctype.subtype env ty expected_ty () 
+      with 
+        Ctype.Subtype (tr1, tr2) -> 
+          raise(Error(lid.loc, env, Not_subtype(tr1, tr2)))
+      );
+    (path, decl, constructors, ty))
+  | _ -> raise (Error (lid.loc, env, Not_a_variant_type lid.txt))
+
+let build_ppat_or_for_variant_spread pat env expected_ty =
+  match pat with
+  | {ppat_desc = Ppat_type lident; ppat_attributes}
+    when Variant_coercion.has_res_pat_variant_spread_attribute ppat_attributes
+    ->
+    let _, _, constructors, ty =
+      extract_type_from_pat_variant_spread !env lident expected_ty
+    in
+    let synthetic_or_patterns =
+      constructors
+      |> List.map (fun (c : Types.constructor_declaration) ->
+              Ast_helper.Pat.mk ~attrs:[Variant_type_spread.mk_pat_from_variant_spread_attr ()] ~loc:lident.loc
+                (Ppat_construct
+                  ( Location.mkloc
+                      (Longident.Lident (Ident.name c.cd_id))
+                      lident.loc,
+                    match c.cd_args with
+                    | Cstr_tuple [] -> None
+                    | _ -> Some (Ast_helper.Pat.any ()) )))
+      |> List.rev
+    in
+    let pat =
+      match synthetic_or_patterns with
+      | [] -> pat
+      | pat :: pats ->
+        List.fold_left (fun p1 p2 -> Ast_helper.Pat.or_ p1 p2) pat pats
+    in
+    Some (pat, ty)
+  | _ -> None
+
+let maybe_expand_variant_spread_in_pattern pattern env expected_ty =
+  match pattern.Parsetree.ppat_desc with
+  | Ppat_type _
+    when Variant_coercion.has_res_pat_variant_spread_attribute
+            pattern.ppat_attributes -> (
+    match build_ppat_or_for_variant_spread pattern env expected_ty with
+    | None -> assert false (* TODO: Fix. *)
+    | Some (pattern, _) -> pattern)
+  | _ -> pattern
+
 (* Type paths *)
 
 let rec expand_path env p =
@@ -1051,6 +1107,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
 
 and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
     sp expected_ty k =
+  let sp = maybe_expand_variant_spread_in_pattern sp env expected_ty in
   let mode' = if mode = Splitting_or then Normal else mode in
   let type_pat ?(constrs=constrs) ?(labels=labels) ?(mode=mode')
       ?(explode=explode) ?(env=env) =
@@ -1125,10 +1182,22 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
       | _ -> assert false
       end
   | Ppat_alias(sq, name) ->
+      let override_type_from_variant_spread, sq =
+        match sq with
+        | {ppat_desc = Ppat_type _; ppat_attributes}
+          when Variant_coercion.has_res_pat_variant_spread_attribute ppat_attributes
+          -> (
+          match build_ppat_or_for_variant_spread sq env expected_ty with
+          | Some (p, ty) -> (Some ty, p)
+          | None -> (None, sq))
+        | _ -> (None, sq)
+      in
       assert (constrs = None);
       type_pat sq expected_ty (fun q ->
         begin_def ();
-        let ty_var = build_as_type !env q in
+        let ty_var = (match override_type_from_variant_spread with 
+        | Some ty -> ty 
+        | None -> build_as_type !env q) in
         end_def ();
         generalize ty_var;
         let id = enter_variable ~is_as_variable:true loc name ty_var in
@@ -4040,6 +4109,8 @@ let report_error env ppf = function
     fprintf ppf
       "Field @{<info>%s@} is not optional in type %a. Use without ?" name
       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
 
 
 let super_report_error_no_wrap_printing_env = report_error

jscomp/ml/typecore.mli

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

jscomp/ml/variant_coercion.ml

@@ -202,4 +202,10 @@ let can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors ~type_at
 let type_is_variant (typ: (Path.t * Path.t * Types.type_declaration) option) = 
   match typ with 
   | Some (_, _, {type_kind = Type_variant _; _}) -> true 
-  | _ -> false
+  | _ -> false
+
+let has_res_pat_variant_spread_attribute attrs =
+  attrs
+  |> List.find_opt (fun (({txt}, _) : Parsetree.attribute) ->
+          txt = "res.patVariantSpread")
+  |> Option.is_some

jscomp/ml/variant_type_spread.ml

@@ -1,6 +1,16 @@
 let mk_constructor_comes_from_spread_attr () : Parsetree.attribute =
   (Location.mknoloc "res.constructor_from_spread", PStr [])
 
+let mk_pat_from_variant_spread_attr () : Parsetree.attribute =
+  (Location.mknoloc "res.patFromVariantSpread", PStr [])
+
+let is_pat_from_variant_spread_attr pat =
+  pat.Typedtree.pat_attributes
+  |> List.exists (fun (a : Parsetree.attribute) ->
+         match a with
+         | {txt = "res.patFromVariantSpread"}, PStr [] -> true
+         | _ -> false)
+
 type variant_type_spread_error =
   | CouldNotFindType
   | HasTypeParams