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

jscomp/syntax/src/res_core.ml

@@ -175,6 +175,8 @@ let suppress_fragile_match_warning_attr =
       ] )
 let make_braces_attr loc = (Location.mkloc "res.braces" loc, Parsetree.PStr [])
 let template_literal_attr = (Location.mknoloc "res.template", Parsetree.PStr [])
+let make_pat_variant_spread_attr =
+  (Location.mknoloc "res.patVariantSpread", Parsetree.PStr [])
 
 let tagged_template_literal_attr =
   (Location.mknoloc "res.taggedTemplate", Parsetree.PStr [])
@@ -1077,6 +1079,13 @@ let rec parse_pattern ?(alias = true) ?(or_ = true) p =
       match p.Parser.token with
       | Lparen -> parse_constructor_pattern_args p constr start_pos attrs
       | _ -> Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr None)
+    | DotDotDot ->
+      Parser.next p;
+      let ident = parse_value_path p in
+      let loc = mk_loc start_pos ident.loc.loc_end in
+      Ast_helper.Pat.type_ ~loc
+        ~attrs:(make_pat_variant_spread_attr :: attrs)
+        ident
     | Hash -> (
       Parser.next p;
       if p.Parser.token == DotDotDot then (

jscomp/syntax/src/res_parsetree_viewer.ml

@@ -97,6 +97,13 @@ let has_await_attribute attrs =
       | _ -> false)
     attrs
 
+let has_res_pat_variant_spread_attribute attrs =
+  List.exists
+    (function
+      | {Location.txt = "res.patVariantSpread"}, _ -> true
+      | _ -> false)
+    attrs
+
 let collect_array_expressions expr =
   match expr.pexp_desc with
   | Pexp_array exprs -> (exprs, None)
@@ -219,7 +226,8 @@ let filter_parsing_attrs attrs =
             Location.txt =
               ( "res.arity" | "res.braces" | "ns.braces" | "res.iflet"
               | "res.namedArgLoc" | "res.optional" | "res.ternary" | "res.async"
-              | "res.await" | "res.template" | "res.taggedTemplate" );
+              | "res.await" | "res.template" | "res.taggedTemplate"
+              | "res.patVariantSpread" );
           },
           _ ) ->
         false

jscomp/syntax/src/res_parsetree_viewer.mli

@@ -26,6 +26,7 @@ val process_function_attributes :
   Parsetree.attributes -> function_attributes_info
 
 val has_await_attribute : Parsetree.attributes -> bool
+val has_res_pat_variant_spread_attribute : Parsetree.attributes -> bool
 
 type if_condition_kind =
   | If of Parsetree.expression

jscomp/syntax/src/res_printer.ml

@@ -2404,6 +2404,10 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl =
             ]
       in
       Doc.group (Doc.concat [variant_name; args_doc])
+    | Ppat_type ident
+      when ParsetreeViewer.has_res_pat_variant_spread_attribute
+             p.ppat_attributes ->
+      Doc.concat [Doc.text "..."; print_ident_path ident cmt_tbl]
     | Ppat_type ident ->
       Doc.concat [Doc.text "#..."; print_ident_path ident cmt_tbl]
     | Ppat_record (rows, open_flag) ->

jscomp/syntax/tests/parsing/grammar/expressions/expected/coerce.res.txt

@@ -3,4 +3,4 @@ let foo = ((Function$ (fun x -> ((x : t) :> int)))[@res.arity 1])
 let _ = (x : int)
 let foo = ((x : int), (y :> float))
 let foo = ((x : int), (y :> float), (z :> int))
-let foo = ((x : int), y, (z :> int))
+let foo = ((x : int), y, (z :> int))

jscomp/test/VariantPatternMatchingSpreads.js

@@ -0,0 +1,33 @@
+type a = One | Two | Three
+type b = | ...a | Four | Five
+type c = Six | Seven
+type d = | ...b | ...c
+
+let doWithA = (a: a) => {
+  switch a {
+  | One => Js.log("aaa")
+  | Two => Js.log("twwwoooo")
+  | Three => Js.log("threeeee")
+  }
+}
+
+let doWithB = (b: b) => {
+  switch b {
+  | One => Js.log("aaa")
+  | _ => Js.log("twwwoooo")
+  }
+}
+
+let lookup = (b: b) =>
+  switch b {
+  | ...a as a => doWithA(a)
+  | Four => Js.log("four")
+  | Five => Js.log("five")
+  }
+
+let lookup2 = (d: d) =>
+  switch d {
+  | ...a as a => doWithA(a)
+  | ...b as b => doWithB(b)
+  | Six | Seven => Js.log("Got rest of d")
+  }