Skip to content

Commit 4ab9a5f

Browse files
authored
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
1 parent ece0fb9 commit 4ab9a5f

20 files changed

+363
-7
lines changed

CHANGELOG.md

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@
1515
#### :rocket: New Feature
1616

1717
- Use FORCE_COLOR environmental variable to force colorized output https://github.com/rescript-lang/rescript-compiler/pull/7033
18+
- 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
1819

1920
#### :bug: Bug fix
2021

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
2+
We've found a bug for you!
3+
/.../fixtures/variant_pattern_type_spreads_not_subtype.res:7:8
4+
5+
5 │ let lookup = (b: b) =>
6+
6 │ switch b {
7+
7 │ | ...c as c => Js.log(c)
8+
8 │ | Four => Js.log("four")
9+
9 │ | Five => Js.log("five")
10+
11+
Type c is not a subtype of b
Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
2+
We've found a bug for you!
3+
/.../fixtures/variant_pattern_type_spreads_not_variant.res:7:8
4+
5+
5 │ let lookup = (b: b) =>
6+
6 │ switch b {
7+
7 │ | ...c as c => Js.log(c)
8+
8 │ | Four => Js.log("four")
9+
9 │ | Five => Js.log("five")
10+
11+
The type c
12+
is not a variant type
Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
type a = One | Two | Three
2+
type b = | ...a | Four | Five
3+
type c = Six | Seven
4+
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")
10+
}
Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
type a = One | Two | Three
2+
type b = | ...a | Four | Five
3+
type c = {name: string}
4+
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")
10+
}

jscomp/ml/parmatch.ml

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2259,11 +2259,13 @@ let check_unused pred casel =
22592259
Location.prerr_warning
22602260
q.pat_loc Warnings.Unused_match
22612261
| Upartial ps ->
2262-
List.iter
2262+
ps
2263+
|> List.filter (fun p ->
2264+
not (Variant_type_spread.is_pat_from_variant_spread_attr p))
2265+
|> List.iter
22632266
(fun p ->
22642267
Location.prerr_warning
22652268
p.pat_loc Warnings.Unused_pat)
2266-
ps
22672269
| Used -> ()
22682270
with Empty | Not_found | NoGuard -> assert false
22692271
end ;

jscomp/ml/typecore.ml

Lines changed: 72 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -74,6 +74,7 @@ type error =
7474
| Empty_record_literal
7575
| Uncurried_arity_mismatch of type_expr * int * int
7676
| Field_not_optional of string * type_expr
77+
| Type_params_not_supported of Longident.t
7778
exception Error of Location.t * Env.t * error
7879
exception Error_forward of Location.error
7980

@@ -595,6 +596,61 @@ let build_or_pat env loc lid =
595596
pat pats in
596597
(path, rp { r with pat_loc = loc },ty)
597598

599+
let extract_type_from_pat_variant_spread env lid expected_ty =
600+
let path, decl = Typetexp.find_type env lid.loc lid.txt in
601+
match decl with
602+
| {type_kind = Type_variant constructors; type_params} -> (
603+
if List.length type_params > 0 then raise (Error (lid.loc, env, Type_params_not_supported lid.txt));
604+
let ty = newgenty (Tconstr (path, [], ref Mnil)) in
605+
(try
606+
Ctype.subtype env ty expected_ty ()
607+
with
608+
Ctype.Subtype (tr1, tr2) ->
609+
raise(Error(lid.loc, env, Not_subtype(tr1, tr2)))
610+
);
611+
(path, decl, constructors, ty))
612+
| _ -> raise (Error (lid.loc, env, Not_a_variant_type lid.txt))
613+
614+
let build_ppat_or_for_variant_spread pat env expected_ty =
615+
match pat with
616+
| {ppat_desc = Ppat_type lident; ppat_attributes}
617+
when Variant_coercion.has_res_pat_variant_spread_attribute ppat_attributes
618+
->
619+
let _, _, constructors, ty =
620+
extract_type_from_pat_variant_spread !env lident expected_ty
621+
in
622+
let synthetic_or_patterns =
623+
constructors
624+
|> List.map (fun (c : Types.constructor_declaration) ->
625+
Ast_helper.Pat.mk ~attrs:[Variant_type_spread.mk_pat_from_variant_spread_attr ()] ~loc:lident.loc
626+
(Ppat_construct
627+
( Location.mkloc
628+
(Longident.Lident (Ident.name c.cd_id))
629+
lident.loc,
630+
match c.cd_args with
631+
| Cstr_tuple [] -> None
632+
| _ -> Some (Ast_helper.Pat.any ()) )))
633+
|> List.rev
634+
in
635+
let pat =
636+
match synthetic_or_patterns with
637+
| [] -> pat
638+
| pat :: pats ->
639+
List.fold_left (fun p1 p2 -> Ast_helper.Pat.or_ p1 p2) pat pats
640+
in
641+
Some (pat, ty)
642+
| _ -> None
643+
644+
let maybe_expand_variant_spread_in_pattern pattern env expected_ty =
645+
match pattern.Parsetree.ppat_desc with
646+
| Ppat_type _
647+
when Variant_coercion.has_res_pat_variant_spread_attribute
648+
pattern.ppat_attributes -> (
649+
match build_ppat_or_for_variant_spread pattern env expected_ty with
650+
| None -> assert false (* TODO: Fix. *)
651+
| Some (pattern, _) -> pattern)
652+
| _ -> pattern
653+
598654
(* Type paths *)
599655

600656
let rec expand_path env p =
@@ -1051,6 +1107,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
10511107

10521108
and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
10531109
sp expected_ty k =
1110+
let sp = maybe_expand_variant_spread_in_pattern sp env expected_ty in
10541111
let mode' = if mode = Splitting_or then Normal else mode in
10551112
let type_pat ?(constrs=constrs) ?(labels=labels) ?(mode=mode')
10561113
?(explode=explode) ?(env=env) =
@@ -1125,10 +1182,22 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
11251182
| _ -> assert false
11261183
end
11271184
| Ppat_alias(sq, name) ->
1185+
let override_type_from_variant_spread, sq =
1186+
match sq with
1187+
| {ppat_desc = Ppat_type _; ppat_attributes}
1188+
when Variant_coercion.has_res_pat_variant_spread_attribute ppat_attributes
1189+
-> (
1190+
match build_ppat_or_for_variant_spread sq env expected_ty with
1191+
| Some (p, ty) -> (Some ty, p)
1192+
| None -> (None, sq))
1193+
| _ -> (None, sq)
1194+
in
11281195
assert (constrs = None);
11291196
type_pat sq expected_ty (fun q ->
11301197
begin_def ();
1131-
let ty_var = build_as_type !env q in
1198+
let ty_var = (match override_type_from_variant_spread with
1199+
| Some ty -> ty
1200+
| None -> build_as_type !env q) in
11321201
end_def ();
11331202
generalize ty_var;
11341203
let id = enter_variable ~is_as_variable:true loc name ty_var in
@@ -4040,6 +4109,8 @@ let report_error env ppf = function
40404109
fprintf ppf
40414110
"Field @{<info>%s@} is not optional in type %a. Use without ?" name
40424111
type_expr typ
4112+
| Type_params_not_supported lid ->
4113+
fprintf ppf "The type %a@ has type parameters, but type parameters is not supported here." longident lid
40434114
40444115
40454116
let super_report_error_no_wrap_printing_env = report_error

jscomp/ml/typecore.mli

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -107,6 +107,7 @@ type error =
107107
| Empty_record_literal
108108
| Uncurried_arity_mismatch of type_expr * int * int
109109
| Field_not_optional of string * type_expr
110+
| Type_params_not_supported of Longident.t
110111
exception Error of Location.t * Env.t * error
111112
exception Error_forward of Location.error
112113

jscomp/ml/variant_coercion.ml

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -202,4 +202,10 @@ let can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors ~type_at
202202
let type_is_variant (typ: (Path.t * Path.t * Types.type_declaration) option) =
203203
match typ with
204204
| Some (_, _, {type_kind = Type_variant _; _}) -> true
205-
| _ -> false
205+
| _ -> false
206+
207+
let has_res_pat_variant_spread_attribute attrs =
208+
attrs
209+
|> List.find_opt (fun (({txt}, _) : Parsetree.attribute) ->
210+
txt = "res.patVariantSpread")
211+
|> Option.is_some

jscomp/ml/variant_type_spread.ml

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,16 @@
11
let mk_constructor_comes_from_spread_attr () : Parsetree.attribute =
22
(Location.mknoloc "res.constructor_from_spread", PStr [])
33

4+
let mk_pat_from_variant_spread_attr () : Parsetree.attribute =
5+
(Location.mknoloc "res.patFromVariantSpread", PStr [])
6+
7+
let is_pat_from_variant_spread_attr pat =
8+
pat.Typedtree.pat_attributes
9+
|> List.exists (fun (a : Parsetree.attribute) ->
10+
match a with
11+
| {txt = "res.patFromVariantSpread"}, PStr [] -> true
12+
| _ -> false)
13+
414
type variant_type_spread_error =
515
| CouldNotFindType
616
| HasTypeParams

0 commit comments

Comments
 (0)