poc of type spreads of regular variants in patterns

Author: zth

jscomp/ml/typecore.ml

@@ -591,6 +591,62 @@ let build_or_pat env loc lid =
           pat pats in
       (path, rp { r with pat_loc = loc },ty)
 
+let build_or_pat_for_variant_spread env loc lid expected_ty =
+  let path, decl = Typetexp.find_type env lid.loc lid.txt in
+  match decl with
+  | {type_kind = Type_variant constructors} -> (
+    (* TODO: Probably problematic that we don't account for type params here? *)
+    let ty = newty (Tconstr (path, [], ref Mnil)) in
+    let gloc = {loc with Location.loc_ghost = true} in
+    let pats =
+      constructors
+      |> List.map
+            (fun (c : Types.constructor_declaration) : Typedtree.pattern ->
+              let lid = Longident.Lident (Ident.name c.cd_id) in
+              {
+                pat_desc =
+                  Tpat_construct
+                    ( {loc = Location.none; txt = lid},
+                      Env.lookup_constructor ~loc:c.cd_loc lid env,
+                      match c.cd_args with
+                      | Cstr_tuple [] -> []
+                      | _ ->
+                        [
+                          {
+                            pat_desc = Tpat_any;
+                            pat_loc = Location.none;
+                            pat_env = env;
+                            pat_type = expected_ty;
+                            pat_extra = [];
+                            pat_attributes = [];
+                          };
+                        ] );
+                pat_loc = Location.none;
+                pat_extra = [];
+                pat_type = expected_ty;
+                pat_env = env;
+                pat_attributes = [];
+              })
+    in
+    match pats with
+    | [] -> raise (Error (lid.loc, env, Not_a_variant_type lid.txt))
+    | pat :: pats ->
+      let r =
+        List.fold_left
+          (fun pat pat0 ->
+            {
+              Typedtree.pat_desc = Tpat_or (pat0, pat, None);
+              pat_extra = [];
+              pat_loc = gloc;
+              pat_env = env;
+              pat_type = expected_ty;
+              pat_attributes = [];
+            })
+          pat pats
+      in
+      (path, rp {r with pat_loc = loc}, ty))
+  | _ -> raise (Error (lid.loc, env, Not_a_variant_type lid.txt))
+
 (* Type paths *)
 
 let rec expand_path env p =
@@ -1111,6 +1167,18 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
           }
       | _ -> assert false
       end
+    | Ppat_alias({ppat_desc=Ppat_type lid; ppat_attributes}, name) when Variant_coercion.has_res_pat_variant_spread_attribute ppat_attributes ->
+      let (_, p, ty) = build_or_pat_for_variant_spread !env loc lid expected_ty in
+      Ctype.subtype !env ty expected_ty ();
+      assert (constrs = None);
+
+      let id = enter_variable ~is_as_variable:true loc name ty in
+      rp k {
+        pat_desc = Tpat_alias(p, id, name);
+        pat_loc = loc; pat_extra=[];
+        pat_type = expected_ty;
+        pat_attributes = sp.ppat_attributes;
+        pat_env = !env }
   | Ppat_alias(sq, name) ->
       assert (constrs = None);
       type_pat sq expected_ty (fun q ->
@@ -1435,6 +1503,12 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
           | _ -> {p with pat_type = ty;
                   pat_extra = extra :: p.pat_extra}
         in k p)
+  | Ppat_type lid when Variant_coercion.has_res_pat_variant_spread_attribute sp.ppat_attributes ->
+    let (path, p, ty) = build_or_pat_for_variant_spread !env loc lid expected_ty in
+      Ctype.subtype !env ty expected_ty ();
+      assert (constrs = None);
+    k { p with pat_extra =
+      (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra }
   | Ppat_type lid ->
       let (path, p,ty) = build_or_pat !env loc lid in
       unify_pat_types loc !env ty expected_ty;

jscomp/ml/variant_coercion.ml

@@ -151,3 +151,11 @@ let variant_configuration_can_be_coerced_raises ~is_spread_context ~left_loc
               right_loc;
               error = TagName {left_tag; right_tag};
             }))
+
+let has_res_pat_variant_spread_attribute attrs =
+  attrs
+  |> List.find_opt (fun (({txt}, _) : Parsetree.attribute) ->
+          txt = "res.patVariantSpread")
+  |> Option.is_some
+
+  

jscomp/syntax/src/res_core.ml

@@ -175,6 +175,8 @@ let suppressFragileMatchWarningAttr =
       ] )
 let makeBracesAttr loc = (Location.mkloc "res.braces" loc, Parsetree.PStr [])
 let templateLiteralAttr = (Location.mknoloc "res.template", Parsetree.PStr [])
+let makePatVariantSpreadAttr =
+  (Location.mknoloc "res.patVariantSpread", Parsetree.PStr [])
 
 let taggedTemplateLiteralAttr =
   (Location.mknoloc "res.taggedTemplate", Parsetree.PStr [])
@@ -1077,6 +1079,11 @@ let rec parsePattern ?(alias = true) ?(or_ = true) p =
       match p.Parser.token with
       | Lparen -> parseConstructorPatternArgs p constr startPos attrs
       | _ -> Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr None)
+    | DotDotDot ->
+      Parser.next p;
+      let ident = parseValuePath p in
+      let loc = mkLoc startPos ident.loc.loc_end in
+      Ast_helper.Pat.type_ ~loc ~attrs:(makePatVariantSpreadAttr :: attrs) ident
     | Hash -> (
       Parser.next p;
       if p.Parser.token == DotDotDot then (

jscomp/syntax/src/res_parsetree_viewer.ml

@@ -104,6 +104,13 @@ let hasAwaitAttribute attrs =
       | _ -> false)
     attrs
 
+let hasResPatVariantSpreadAttribute attrs =
+  List.exists
+    (function
+      | {Location.txt = "res.patVariantSpread"}, _ -> true
+      | _ -> false)
+    attrs
+
 let collectArrayExpressions expr =
   match expr.pexp_desc with
   | Pexp_array exprs -> (exprs, None)
@@ -225,7 +232,7 @@ let filterParsingAttrs attrs =
               ( "bs" | "res.uapp" | "res.arity" | "res.braces" | "ns.braces"
               | "res.iflet" | "res.namedArgLoc" | "res.optional" | "res.ternary"
               | "res.async" | "res.await" | "res.template"
-              | "res.taggedTemplate" );
+              | "res.taggedTemplate" | "res.patVariantSpread" );
           },
           _ ) ->
         false

jscomp/syntax/src/res_parsetree_viewer.mli

@@ -33,6 +33,7 @@ type functionAttributesInfo = {
 val processFunctionAttributes : Parsetree.attributes -> functionAttributesInfo
 
 val hasAwaitAttribute : Parsetree.attributes -> bool
+val hasResPatVariantSpreadAttribute : Parsetree.attributes -> bool
 
 type ifConditionKind =
   | If of Parsetree.expression

jscomp/syntax/src/res_printer.ml

@@ -2371,7 +2371,12 @@ and printPattern ~state (p : Parsetree.pattern) cmtTbl =
       in
       Doc.group (Doc.concat [variantName; argsDoc])
     | Ppat_type ident ->
-      Doc.concat [Doc.text "#..."; printIdentPath ident cmtTbl]
+      let prefix =
+        if ParsetreeViewer.hasResPatVariantSpreadAttribute p.ppat_attributes
+        then ""
+        else "#"
+      in
+      Doc.concat [Doc.text (prefix ^ "..."); printIdentPath ident cmtTbl]
     | Ppat_record (rows, openFlag) ->
       Doc.group
         (Doc.concat

jscomp/test/VariantPatternMatchingSpreads.js

@@ -0,0 +1,32 @@
+type a = One | Two | Three
+type a1 = One
+type b = | ...a | Four | Five
+
+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 = (b: b) =>
+  switch b {
+  | ...a => Js.log("spread")
+  | Four => Js.log("four")
+  | Five => Js.log("five")
+  }