From df9b01ae4594d9563383beec0e877d6846959fdc Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 26 Apr 2023 10:27:00 +0200 Subject: [PATCH] Make untagged variants understand payloads defined as records. When a payload `A(t)` is a type `t` defined as a record, consider `A` as an object case, not an unknown case. (unless t is an unboxed record) --- CHANGELOG.md | 1 + jscomp/core/matching_polyfill.ml | 2 +- jscomp/ml/ast_untagged_variants.ml | 32 +++++++++++++++++------------- jscomp/ml/typedecl.ml | 2 +- jscomp/test/UntaggedVariants.js | 14 +++++++++++++ jscomp/test/UntaggedVariants.res | 14 +++++++++++++ 6 files changed, 49 insertions(+), 16 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e9aa2d03b1..f936433aa0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -19,6 +19,7 @@ - `node` (default): Drop extensions. - `node16`: Use TS output's extensions. Make it ESM-compatible. - `bundler`: Use TS input's extensions. Make it ESM-compatible. +- Make untagged variants understand payloads defined as records. https://github.com/rescript-lang/rescript-compiler/pull/6208 #### :boom: Breaking Change diff --git a/jscomp/core/matching_polyfill.ml b/jscomp/core/matching_polyfill.ml index 1c02ecc2ed..8afd89636e 100644 --- a/jscomp/core/matching_polyfill.ml +++ b/jscomp/core/matching_polyfill.ml @@ -25,7 +25,7 @@ let names_from_construct_pattern (pat : Typedtree.pattern) = let rec resolve_path n (path : Path.t) = match Env.find_type path pat.pat_env with - | { type_kind = Type_variant cstrs; _ } -> Ast_untagged_variants.names_from_type_variant cstrs + | { type_kind = Type_variant cstrs; _ } -> Ast_untagged_variants.names_from_type_variant ~env:pat.pat_env cstrs | { type_kind = Type_abstract; type_manifest = Some t; _ } -> ( match (Ctype.unalias t).desc with | Tconstr (pathn, _, _) -> diff --git a/jscomp/ml/ast_untagged_variants.ml b/jscomp/ml/ast_untagged_variants.ml index 6ebe92a94d..78791e8869 100644 --- a/jscomp/ml/ast_untagged_variants.ml +++ b/jscomp/ml/ast_untagged_variants.ml @@ -92,7 +92,7 @@ let () = None ) -let get_untagged (cstr: Types.constructor_declaration) : block_type option = +let get_untagged ~env (cstr: Types.constructor_declaration) : block_type option = match process_untagged cstr.cd_attributes, cstr.cd_args with | false, _ -> None | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when Path.same path Predef.path_string -> @@ -105,17 +105,21 @@ let get_untagged (cstr: Types.constructor_declaration) : block_type option = Some Array | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when Path. same path Predef.path_string -> Some StringType - | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] -> - (match Path.name path with - | "Js.Dict.t" - | "Js_dict.t" -> Some Object - | _ -> Some Unknown) - | true, Cstr_tuple (_ :: _ :: _) -> + | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when + let name = Path.name path in + name = "Js.Dict.t" || name = "Js_dict.t" -> + Some Object + | true, Cstr_tuple [ty] -> + let default = Some Unknown in + (match Ctype.extract_concrete_typedecl env ty with + | (_, _, {type_kind = Type_record (_, Record_unboxed _)}) -> default + | (_, _, {type_kind = Type_record (_, _)}) -> Some Object + | _ -> default + | exception _ -> default + ) +| true, Cstr_tuple (_ :: _ :: _) -> (* C(_, _) with at least 2 args is an object *) Some Object - | true, Cstr_tuple [_] -> - (* Every other single payload is unknown *) - Some Unknown | true, Cstr_record _ -> (* inline record is an object *) Some Object @@ -209,13 +213,13 @@ let checkInvariant ~isUntaggedDef ~(consts : (Location.t * literal) list) ~(bloc invariant loc | None -> ()) -let names_from_type_variant ?(isUntaggedDef=false) (cstrs : Types.constructor_declaration list) = +let names_from_type_variant ?(isUntaggedDef=false) ~env (cstrs : Types.constructor_declaration list) = let get_cstr_name (cstr: Types.constructor_declaration) = (cstr.cd_loc, { name = Ident.name cstr.cd_id; literal_type = process_literal_type cstr.cd_attributes }) in let get_block cstr : block = - {literal = snd (get_cstr_name cstr); tag_name = get_tag_name cstr; block_type = get_untagged cstr} in + {literal = snd (get_cstr_name cstr); tag_name = get_tag_name cstr; block_type = get_untagged ~env cstr} in let consts, blocks = Ext_list.fold_left cstrs ([], []) (fun (consts, blocks) cstr -> if is_nullary_variant cstr.cd_args then @@ -229,6 +233,6 @@ let names_from_type_variant ?(isUntaggedDef=false) (cstrs : Types.constructor_de let blocks = Ext_array.reverse_of_list blocks in Some { consts; blocks } -let check_well_formed ~isUntaggedDef (cstrs: Types.constructor_declaration list) = - ignore (names_from_type_variant ~isUntaggedDef cstrs) +let check_well_formed ~env ~isUntaggedDef (cstrs: Types.constructor_declaration list) = + ignore (names_from_type_variant ~env ~isUntaggedDef cstrs) diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index e564840266..b6de66a304 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -422,7 +422,7 @@ let transl_declaration ~typeRecordAsObject env sdecl id = in let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in let isUntaggedDef = Ast_untagged_variants.has_untagged sdecl.ptype_attributes in - Ast_untagged_variants.check_well_formed ~isUntaggedDef cstrs; + Ast_untagged_variants.check_well_formed ~env ~isUntaggedDef cstrs; Ttype_variant tcstrs, Type_variant cstrs, sdecl | Ptype_record lbls_ -> let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "res.optional") in diff --git a/jscomp/test/UntaggedVariants.js b/jscomp/test/UntaggedVariants.js index 2ee7d68e51..1e6962eb4a 100644 --- a/jscomp/test/UntaggedVariants.js +++ b/jscomp/test/UntaggedVariants.js @@ -1,6 +1,7 @@ // Generated by ReScript, PLEASE EDIT WITH CARE 'use strict'; +var Caml_array = require("../../lib/js/caml_array.js"); function classify(x) { if (x === "A" && typeof x !== "number") { @@ -293,6 +294,18 @@ var OverlapObject = { checkEnum: checkEnum$2 }; +function classify$7(v) { + if (Array.isArray(v)) { + return Caml_array.get(v, 0); + } else { + return v.x; + } +} + +var RecordIsObject = { + classify: classify$7 +}; + var i = 42; var i2 = 42.5; @@ -330,4 +343,5 @@ exports.TrickyNested = TrickyNested; exports.OverlapString = OverlapString; exports.OverlapNumber = OverlapNumber; exports.OverlapObject = OverlapObject; +exports.RecordIsObject = RecordIsObject; /* l2 Not a pure module */ diff --git a/jscomp/test/UntaggedVariants.res b/jscomp/test/UntaggedVariants.res index 8a1d5d3b8c..690749e9b1 100644 --- a/jscomp/test/UntaggedVariants.res +++ b/jscomp/test/UntaggedVariants.res @@ -235,3 +235,17 @@ module OverlapObject = { | Object(_) => "Object..." } } + +module RecordIsObject = { + // @unboxed + // this is not allowed + type r = {x:int} + + @unboxed + type t = | Array(array) | Record(r) + + let classify = v => switch v { + | Record({x}) => x + | Array(a) => a[0] + } +} \ No newline at end of file