diff --git a/CHANGELOG.md b/CHANGELOG.md index 6efb676a86..a5b3c14401 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -25,6 +25,10 @@ - Deprecate JSON.Classify.classify. https://github.com/rescript-lang/rescript/pull/7315 +#### :bug: Bug fix + +- Fix recursive untagged variant type checking by delaying well-formedness checks until environment construction completes. [#7320](https://github.com/rescript-lang/rescript/pull/7320) + # 12.0.0-alpha.9 #### :boom: Breaking Change diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index d5c8940a65..6966a7a10e 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -377,8 +377,12 @@ let names_from_type_variant ?(is_untagged_def = false) ~env let blocks = Ext_array.reverse_of_list blocks in Some {consts; blocks} -let check_well_formed ~env ~is_untagged_def - (cstrs : Types.constructor_declaration list) = +type well_formedness_check = { + is_untagged_def: bool; + cstrs: Types.constructor_declaration list; +} + +let check_well_formed ~env {is_untagged_def; cstrs} = ignore (names_from_type_variant ~env ~is_untagged_def cstrs) let has_undefined_literal attrs = process_tag_type attrs = Some Undefined diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 902964f76b..f31ae8f7fd 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -293,7 +293,7 @@ let make_constructor env type_path type_params sargs sret_type = any type variable present in [ty]. *) -let transl_declaration ~type_record_as_object env sdecl id = +let transl_declaration ~type_record_as_object ~untagged_wfc env sdecl id = (* Bind type parameters *) reset_type_variables (); Ctype.begin_def (); @@ -529,7 +529,11 @@ let transl_declaration ~type_record_as_object env sdecl id = let is_untagged_def = Ast_untagged_variants.has_untagged sdecl.ptype_attributes in - Ast_untagged_variants.check_well_formed ~env ~is_untagged_def cstrs; + let well_formedness_check : Ast_untagged_variants.well_formedness_check = + {is_untagged_def; cstrs} + in + (* delay the check until the newenv is created to handle recursive types *) + untagged_wfc := well_formedness_check :: !untagged_wfc; (Ttype_variant tcstrs, Type_variant cstrs, sdecl) | Ptype_record lbls_ -> ( let optional_labels = @@ -1467,10 +1471,12 @@ let transl_type_decl env rec_flag sdecl_list = | Asttypes.Recursive | Asttypes.Nonrecursive -> (id, None) in let type_record_as_object = ref false in + let untagged_wfc = ref [] in let transl_declaration name_sdecl (id, slot) = current_slot := slot; Builtin_attributes.warning_scope name_sdecl.ptype_attributes (fun () -> - transl_declaration ~type_record_as_object temp_env name_sdecl id) + transl_declaration ~type_record_as_object ~untagged_wfc temp_env + name_sdecl id) in let tdecls = List.map2 transl_declaration sdecl_list (List.map id_slots id_list) @@ -1528,6 +1534,9 @@ let transl_type_decl env rec_flag sdecl_list = | None -> ()) sdecl_list tdecls; (* Check that constraints are enforced *) + List.iter + (fun check -> Ast_untagged_variants.check_well_formed ~env:newenv check) + !untagged_wfc; List.iter2 (check_constraints ~type_record_as_object newenv) sdecl_list decls; (* Name recursion *) let decls = diff --git a/tests/tests/src/UntaggedVariants.mjs b/tests/tests/src/UntaggedVariants.mjs index 51da690507..eab12455bb 100644 --- a/tests/tests/src/UntaggedVariants.mjs +++ b/tests/tests/src/UntaggedVariants.mjs @@ -600,6 +600,12 @@ let ObjectAndNull = { printLength: printLength }; +let RecursiveType = { + o: { + foo: "hello" + } +}; + let $$Array; let i = 42; @@ -653,5 +659,6 @@ export { OnlyOne, MergeCases, ObjectAndNull, + RecursiveType, } /* l2 Not a pure module */ diff --git a/tests/tests/src/UntaggedVariants.res b/tests/tests/src/UntaggedVariants.res index 72644ce1c2..e35fec2afd 100644 --- a/tests/tests/src/UntaggedVariants.res +++ b/tests/tests/src/UntaggedVariants.res @@ -469,3 +469,10 @@ module ObjectAndNull = { | _ => () } } + +module RecursiveType = { + type rec object2 = {foo: string} + @unboxed and tagged2 = Object(object2) | Fn(unit => object2) + + let o = Object({foo: "hello"}) +}