Skip to content
Merged
Show file tree
Hide file tree
Changes from 9 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
1 change: 1 addition & 0 deletions CHANGELOG.md
Original file line number Diff line number Diff line change
Expand Up @@ -26,6 +26,7 @@
- Add `reset` to `experimental_features` to correctly reset playground. https://github.com/rescript-lang/rescript/pull/7868
- Fix crash with `@get` on external of type `unit => 'a`. https://github.com/rescript-lang/rescript/pull/7866
- Fix record type spreads in inline records. https://github.com/rescript-lang/rescript/pull/7859
- Make inline record fields that overlap with a variant's tag a compile error. https://github.com/rescript-lang/rescript/pull/7875

#### :memo: Documentation

Expand Down
49 changes: 49 additions & 0 deletions compiler/ml/ast_untagged_variants.ml
Original file line number Diff line number Diff line change
Expand Up @@ -57,6 +57,7 @@ type error =
| Duplicated_bs_as
| InvalidVariantTagAnnotation
| InvalidUntaggedVariantDefinition of untagged_error
| TagFieldNameConflict of string * string
exception Error of Location.t * error

let report_error ppf =
Expand Down Expand Up @@ -90,6 +91,11 @@ let report_error ppf =
| DuplicateLiteral s -> "Duplicate literal " ^ s ^ "."
| ConstructorMoreThanOneArg name ->
"Constructor " ^ name ^ " has more than one argument.")
| TagFieldNameConflict (constructor_name, field_name) ->
fprintf ppf
"Constructor %s: the @tag name \"%s\" conflicts with inline record field \
\"%s\". Use a different @tag name or rename the field."
constructor_name field_name field_name

(* Type of the runtime representation of an untagged block (case with payoad) *)
type block_type =
Expand Down Expand Up @@ -317,6 +323,19 @@ let process_tag_name (attrs : Parsetree.attributes) =
| _ -> ());
!st

let process_as_name (attrs : Parsetree.attributes) =
Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This function is based on process_tag_name, located above:

let process_tag_name (attrs : Parsetree.attributes) =
let st = ref None in
Ext_list.iter attrs (fun ({txt; loc}, payload) ->
match txt with
| "tag" ->
if !st = None then (
(match Ast_payload.is_single_string payload with
| None -> ()
| Some (s, _dec) -> st := Some s);
if !st = None then raise (Error (loc, InvalidVariantTagAnnotation)))
else raise (Error (loc, Duplicated_bs_as))
| _ -> ());
!st

let st = ref None in
Ext_list.iter attrs (fun ({txt; loc}, payload) ->
match txt with
| "as" ->
if !st = None then
match Ast_payload.is_single_string payload with
| None -> ()
| Some (s, _dec) -> st := Some s
else raise (Error (loc, Duplicated_bs_as))
| _ -> ());
!st

let get_tag_name (cstr : Types.constructor_declaration) =
process_tag_name cstr.cd_attributes

Expand Down Expand Up @@ -462,12 +481,42 @@ let names_from_type_variant ?(is_untagged_def = false) ~env
let blocks = Ext_array.reverse_of_list blocks in
Some {consts; blocks}

let check_tag_field_conflicts (cstrs : Types.constructor_declaration list) =
List.iter
(fun (cstr : Types.constructor_declaration) ->
(* Get the effective tag name - either explicit @tag or constructor name *)
let tag_name =
match process_tag_name cstr.cd_attributes with
| Some explicit_tag -> explicit_tag
| None -> Ident.name cstr.cd_id (* Default to constructor name *)
in
match cstr.cd_args with
| Cstr_record fields ->
List.iter
(fun (field : Types.label_declaration) ->
(* Get the effective field name in JavaScript output *)
let effective_field_name =
match process_as_name field.ld_attributes with
| Some as_name -> as_name (* Use @as name if present *)
| None -> Ident.name field.ld_id (* Otherwise use field name *)
in
(* Check if effective field name conflicts with tag *)
if effective_field_name = tag_name then
raise
(Error
( cstr.cd_loc,
TagFieldNameConflict (Ident.name cstr.cd_id, tag_name) )))
fields
| _ -> ())
cstrs

type well_formedness_check = {
is_untagged_def: bool;
cstrs: Types.constructor_declaration list;
}

let check_well_formed ~env {is_untagged_def; cstrs} =
check_tag_field_conflicts cstrs;
ignore (names_from_type_variant ~env ~is_untagged_def cstrs)

let has_undefined_literal attrs = process_tag_type attrs = Some Undefined
Expand Down
Original file line number Diff line number Diff line change
@@ -0,0 +1,8 @@

We've found a bug for you!
/.../fixtures/duplicate_as_tag_inline_record.res:1:35-37

1 │ type animal = Cat({@as("catName") @as("catName2") name: string})
2 │

duplicate @as
Original file line number Diff line number Diff line change
@@ -0,0 +1,10 @@

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

1 │ @tag("name")
2 │ type animal = Cat({name: string})
3 │
4 │ let cat = Cat({name: "my cat"})

Constructor Cat: the @tag name "name" conflicts with inline record field "name". Use a different @tag name or rename the field.
Original file line number Diff line number Diff line change
@@ -0,0 +1,10 @@

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

1 │ @tag("name")
2 │ type animal = Cat({@as("name") catName: string})
3 │
4 │ let cat = Cat({catName: "my cat"})

Constructor Cat: the @tag name "name" conflicts with inline record field "name". Use a different @tag name or rename the field.
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
type animal = Cat({@as("catName") @as("catName2") name: string})
Original file line number Diff line number Diff line change
@@ -0,0 +1,4 @@
@tag("name")
type animal = Cat({name: string})

let cat = Cat({name: "my cat"})
Original file line number Diff line number Diff line change
@@ -0,0 +1,4 @@
@tag("name")
type animal = Cat({@as("name") catName: string})

let cat = Cat({catName: "my cat"})
Loading