Skip to content

Variant type spreads #6316

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 9 commits into from
Jul 7, 2023
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
Original file line number Diff line number Diff line change
@@ -0,0 +1,11 @@

We've found a bug for you!
/.../fixtures/variant_spread_duplicate_constructors.res:3:22

1 │ type a = One | Two
2 │ type b = Two | Three
3 │ type c = | ...a | ...b | Four
4 │

Variant b has a constructor named Two, but a constructor named Two already exists in the variant it's spread into.
You cannot spread variants with overlapping constructors.
Original file line number Diff line number Diff line change
@@ -0,0 +1,10 @@

We've found a bug for you!
/.../fixtures/variant_spread_inline_records.res:4:16-30

2 │ type b = | ...a | Three
3 │
4 │ let b: b = One({name: "hello"})

Some required record fields are missing:
age. If this is a component, add the missing props.
Original file line number Diff line number Diff line change
@@ -0,0 +1,8 @@

We've found a bug for you!
/.../fixtures/variant_spread_recursive.res:1:65

1 │ type rec a = One | Two | Three and b = Four | Five and c = | ...a | ...b
2 │

This type could not be found. It's only possible to spread variants that are known as the spread happens. This means for example that you can't spread variants in recursive definitions.
Original file line number Diff line number Diff line change
@@ -0,0 +1,9 @@

We've found a bug for you!
/.../fixtures/variant_spread_tag_missing.res:2:15

1 │ @tag("kind") type a = One(int) | Two(string)
2 │ type b = | ...a | Three(bool)
3 │

The @tag attribute does not match for this variant and the variant where this is spread. Both variants must have the same @tag attribute configuration, or no @tag attribute at all.
Original file line number Diff line number Diff line change
@@ -0,0 +1,9 @@

We've found a bug for you!
/.../fixtures/variant_spread_tag_value_mismatch.res:2:28

1 │ @tag("kind") type a = One(int) | Two(string)
2 │ @tag("name") type b = | ...a | Three(bool)
3 │

The @tag attribute does not match for this variant and the variant where this is spread. Both variants must have the same @tag attribute configuration, or no @tag attribute at all.
Original file line number Diff line number Diff line change
@@ -0,0 +1,8 @@

We've found a bug for you!
/.../fixtures/variant_spread_type_parameters.res:2:15

1 │ type a<'a> = One | Two('a)
2 │ type b = | ...a<int> | Three

Type parameters are not supported in variant type spreads.
Original file line number Diff line number Diff line change
@@ -0,0 +1,9 @@

We've found a bug for you!
/.../fixtures/variant_spread_unboxed_mismatch.res:2:15

1 │ @unboxed type a = One(int) | Two(string)
2 │ type b = | ...a | Three(bool)
3 │

This variant is unboxed, but the variant where this is spread is not. Both variants unboxed configuration must match.
Original file line number Diff line number Diff line change
@@ -0,0 +1,3 @@
type a = One | Two
type b = Two | Three
type c = | ...a | ...b | Four
Original file line number Diff line number Diff line change
@@ -0,0 +1,4 @@
type a = One({name: string, age: int}) | Two
type b = | ...a | Three

let b: b = One({name: "hello"})
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
type rec a = One | Two | Three and b = Four | Five and c = | ...a | ...b
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
@tag("kind") type a = One(int) | Two(string)
type b = | ...a | Three(bool)
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
@tag("kind") type a = One(int) | Two(string)
@tag("name") type b = | ...a | Three(bool)
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
type a<'a> = One | Two('a)
type b = | ...a<int> | Three
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
@unboxed type a = One(int) | Two(string)
type b = | ...a | Three(bool)
151 changes: 134 additions & 17 deletions jscomp/ml/typedecl.ml
Original file line number Diff line number Diff line change
Expand Up @@ -53,6 +53,8 @@ type error =
| Bad_unboxed_attribute of string
| Boxed_and_unboxed
| Nonrec_gadt
| Variant_runtime_representation_mismatch of Variant_coercion.variant_error
| Variant_spread_fail of Variant_type_spread.variant_type_spread_error

open Typedtree

Expand Down Expand Up @@ -379,34 +381,109 @@ let transl_declaration ~typeRecordAsObject env sdecl id =
let copy_tag_attr_from_decl attr =
let tag_attrs = Ext_list.filter sdecl.ptype_attributes (fun ({txt}, _) -> txt = "tag" || txt = Ast_untagged_variants.untagged) in
if tag_attrs = [] then attr else tag_attrs @ attr in
let constructors_from_variant_spreads = Hashtbl.create 10 in
let make_cstr scstr =
let name = Ident.create scstr.pcd_name.txt in
let targs, tret_type, args, ret_type, _cstr_params =
make_constructor env (Path.Pident id) params
scstr.pcd_args scstr.pcd_res
in
let tcstr =
{ cd_id = name;
cd_name = scstr.pcd_name;
cd_args = targs;
cd_res = tret_type;
cd_loc = scstr.pcd_loc;
cd_attributes = scstr.pcd_attributes |> copy_tag_attr_from_decl }
in
let cstr =
{ Types.cd_id = name;
cd_args = args;
cd_res = ret_type;
cd_loc = scstr.pcd_loc;
cd_attributes = scstr.pcd_attributes |> copy_tag_attr_from_decl }
in
if String.starts_with scstr.pcd_name.txt ~prefix:"..." then (
(* Any constructor starting with "..." represents a variant type spread, and
will have the spread variant itself as a single argument.

We pull that variant type out, and then track the type of each of its
constructors, so that we can replace our dummy constructors added before
type checking with the realtypes for each constructor.
*)
(match args with
| Cstr_tuple [spread_variant] -> (
match Ctype.extract_concrete_typedecl env spread_variant with
| (_, _, {type_kind=Type_variant constructors}) -> (
constructors |> List.iter(fun (c: Types.constructor_declaration) ->
Hashtbl.add constructors_from_variant_spreads c.cd_id.name c)
)
| _ -> ()
)
| _ -> ());
None)
else (
(* Check if this constructor is from a variant spread. If so, we need to replace
its type with the right type we've pulled from the type checked spread variant
itself. *)
let tcstr, cstr = match Hashtbl.find_opt constructors_from_variant_spreads (Ident.name name) with
| Some cstr ->
let tcstr =
{
cd_id = name;
cd_name = scstr.pcd_name;
cd_args =
(match cstr.cd_args with
| Cstr_tuple args ->
Cstr_tuple
(args
|> List.map (fun texpr : Typedtree.core_type ->
{
ctyp_attributes = cstr.cd_attributes;
ctyp_loc = cstr.cd_loc;
ctyp_env = env;
ctyp_type = texpr;
ctyp_desc = Ttyp_any;
(* This is fine because the type checker seems to only look at `ctyp_type` for type checking. *)
}))
| Cstr_record lbls ->
Cstr_record
(lbls
|> List.map
(fun (l : Types.label_declaration) : Typedtree.label_declaration
->
{
ld_id = l.ld_id;
ld_name = Location.mkloc (Ident.name l.ld_id) l.ld_loc;
ld_mutable = l.ld_mutable;
ld_type =
{
ctyp_desc = Ttyp_any;
ctyp_type = l.ld_type;
ctyp_env = env;
ctyp_loc = l.ld_loc;
ctyp_attributes = [];
};
ld_loc = l.ld_loc;
ld_attributes = l.ld_attributes;
})));
cd_res = tret_type;
(* This is also strictly wrong, but is fine because the type checker does not look at this field. *)
cd_loc = scstr.pcd_loc;
cd_attributes = scstr.pcd_attributes |> copy_tag_attr_from_decl;
}
in
tcstr, cstr
| None ->
let tcstr =
{ cd_id = name;
cd_name = scstr.pcd_name;
cd_args = targs;
cd_res = tret_type;
cd_loc = scstr.pcd_loc;
cd_attributes = scstr.pcd_attributes |> copy_tag_attr_from_decl }
in
let cstr =
{ Types.cd_id = name;
cd_args = args;
cd_res = ret_type;
cd_loc = scstr.pcd_loc;
cd_attributes = scstr.pcd_attributes |> copy_tag_attr_from_decl }
in
tcstr, cstr
in Some (tcstr, cstr)
)
in
let make_cstr scstr =
Builtin_attributes.warning_scope scstr.pcd_attributes
(fun () -> make_cstr scstr)
in
let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in
let tcstrs, cstrs = List.split (List.filter_map make_cstr scstrs) in
let isUntaggedDef = Ast_untagged_variants.has_untagged sdecl.ptype_attributes in
Ast_untagged_variants.check_well_formed ~env ~isUntaggedDef cstrs;
Ttype_variant tcstrs, Type_variant cstrs, sdecl
Expand Down Expand Up @@ -1270,7 +1347,12 @@ let transl_type_decl env rec_flag sdecl_list =
{sdecl with
ptype_name; ptype_kind = Ptype_abstract; ptype_manifest = None})
fixed_types
@ sdecl_list
@ (try
sdecl_list |> Variant_type_spread.expand_variant_spreads env
with
| Variant_coercion.VariantConfigurationError ((VariantError {left_loc}) as err) -> raise(Error(left_loc, Variant_runtime_representation_mismatch err))
| Variant_type_spread.VariantTypeSpreadError (loc, err) -> raise(Error(loc, Variant_spread_fail err))
)
in

(* Create identifiers. *)
Expand Down Expand Up @@ -1324,6 +1406,7 @@ let transl_type_decl env rec_flag sdecl_list =
List.map2 transl_declaration sdecl_list (List.map id_slots id_list) in
let decls =
List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in
let sdecl_list = Variant_type_spread.expand_dummy_constructor_args sdecl_list decls in
current_slot := None;
(* Check for duplicates *)
check_duplicates sdecl_list;
Expand Down Expand Up @@ -2072,6 +2155,40 @@ let report_error ppf = function
| Nonrec_gadt ->
fprintf ppf
"@[GADT case syntax cannot be used in a 'nonrec' block.@]"
| Variant_runtime_representation_mismatch
(Variant_coercion.VariantError
{is_spread_context; error = Variant_coercion.Untagged {left_is_unboxed}})
->
let other_variant_text =
if is_spread_context then "the variant where this is spread"
else "the other variant"
in
fprintf ppf "@[%s.@]"
("This variant is "
^ (if left_is_unboxed then "unboxed" else "not unboxed")
^ ", but " ^ other_variant_text
^ " is not. Both variants unboxed configuration must match")
| Variant_runtime_representation_mismatch
(Variant_coercion.VariantError
{is_spread_context; error = Variant_coercion.TagName _}) ->
let other_variant_text =
if is_spread_context then "the variant where this is spread"
else "the other variant"
in
fprintf ppf "@[%s.@]"
("The @tag attribute does not match for this variant and "
^ other_variant_text
^ ". Both variants must have the same @tag attribute configuration, or no \
@tag attribute at all")
| Variant_spread_fail Variant_type_spread.CouldNotFindType ->
fprintf ppf "@[This type could not be found. It's only possible to spread variants that are known as the spread happens. This means for example that you can't spread variants in recursive definitions.@]"
| Variant_spread_fail Variant_type_spread.HasTypeParams ->
fprintf ppf "@[Type parameters are not supported in variant type spreads.@]"
| Variant_spread_fail Variant_type_spread.DuplicateConstructor
{variant_with_overlapping_constructor; overlapping_constructor_name} ->
fprintf ppf "@[Variant %s has a constructor named %s, but a constructor named %s already exists in the variant it's spread into.@ You cannot spread variants with overlapping constructors.@]"
variant_with_overlapping_constructor overlapping_constructor_name overlapping_constructor_name


let () =
Location.register_error_of_exn
Expand Down
50 changes: 50 additions & 0 deletions jscomp/ml/variant_coercion.ml
Original file line number Diff line number Diff line change
Expand Up @@ -40,6 +40,20 @@ let variant_representation_matches (c1_attrs : Parsetree.attributes)
| Some s1, Some s2 when s1 = s2 -> true
| _ -> false

type variant_configuration_error =
| Untagged of {left_is_unboxed: bool}
| TagName of {left_tag: string option; right_tag: string option}

type variant_error =
| VariantError of {
left_loc: Location.t;
right_loc: Location.t;
error: variant_configuration_error;
is_spread_context: bool;
}

exception VariantConfigurationError of variant_error

let variant_configuration_can_be_coerced (a1 : Parsetree.attributes)
(a2 : Parsetree.attributes) =
let unboxed =
Expand All @@ -62,3 +76,39 @@ let variant_configuration_can_be_coerced (a1 : Parsetree.attributes)
| _ -> false
in
if not tag then false else true

let variant_configuration_can_be_coerced_raises ~is_spread_context ~left_loc
~right_loc ~(left_attributes : Parsetree.attributes)
~(right_attributes : Parsetree.attributes) =
(match
( Ast_untagged_variants.process_untagged left_attributes,
Ast_untagged_variants.process_untagged right_attributes )
with
| true, true | false, false -> ()
| left, _right ->
raise
(VariantConfigurationError
(VariantError
{
is_spread_context;
left_loc;
right_loc;
error = Untagged {left_is_unboxed = left};
})));

match
( Ast_untagged_variants.process_tag_name left_attributes,
Ast_untagged_variants.process_tag_name right_attributes )
with
| Some host_tag, Some spread_tag when host_tag = spread_tag -> ()
| None, None -> ()
| left_tag, right_tag ->
raise
(VariantConfigurationError
(VariantError
{
is_spread_context;
left_loc;
right_loc;
error = TagName {left_tag; right_tag};
}))
Loading