From 0adc3bc4d97e705b72f09edef416f01bbad81d70 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 7 Jun 2023 05:45:28 +0200 Subject: [PATCH 1/8] Untagged variants error messages Add tests. See https://github.com/rescript-lang/rescript-compiler/issues/6272 --- .../expected/UntaggedNonUnary1.res.expected | 10 ++++++++++ .../expected/UntaggedNonUnary2.res.expected | 9 +++++++++ .../super_errors/expected/UntaggedUnknown.res.expected | 9 +++++++++ .../super_errors/fixtures/UntaggedNonUnary1.res | 2 ++ .../super_errors/fixtures/UntaggedNonUnary2.res | 2 ++ .../super_errors/fixtures/UntaggedUnknown.res | 2 ++ 6 files changed, 34 insertions(+) create mode 100644 jscomp/build_tests/super_errors/expected/UntaggedNonUnary1.res.expected create mode 100644 jscomp/build_tests/super_errors/expected/UntaggedNonUnary2.res.expected create mode 100644 jscomp/build_tests/super_errors/expected/UntaggedUnknown.res.expected create mode 100644 jscomp/build_tests/super_errors/fixtures/UntaggedNonUnary1.res create mode 100644 jscomp/build_tests/super_errors/fixtures/UntaggedNonUnary2.res create mode 100644 jscomp/build_tests/super_errors/fixtures/UntaggedUnknown.res diff --git a/jscomp/build_tests/super_errors/expected/UntaggedNonUnary1.res.expected b/jscomp/build_tests/super_errors/expected/UntaggedNonUnary1.res.expected new file mode 100644 index 0000000000..a03919db69 --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/UntaggedNonUnary1.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/UntaggedNonUnary1.res:2:1-27 + + 1 │ @unboxed + 2 │ type t = Tuple(int, string) + 3 │ + + This type cannot be unboxed because + its constructor has more than one argument. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/UntaggedNonUnary2.res.expected b/jscomp/build_tests/super_errors/expected/UntaggedNonUnary2.res.expected new file mode 100644 index 0000000000..36f92991cb --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/UntaggedNonUnary2.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/UntaggedNonUnary2.res:2:1-42 + + 1 │ @unboxed + 2 │ type t = Tuple(int, string) | Float(float) + 3 │ + + This type cannot be unboxed because it has more than one constructor. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/UntaggedUnknown.res.expected b/jscomp/build_tests/super_errors/expected/UntaggedUnknown.res.expected new file mode 100644 index 0000000000..8acc7cc3bb --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/UntaggedUnknown.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/UntaggedUnknown.res:2:10-31 + + 1 │ @unboxed + 2 │ type t = Tuple((float, string)) | Float(float) + 3 │ + + This untagged variant definition is invalid: An unknown case must be the only case with payloads. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/UntaggedNonUnary1.res b/jscomp/build_tests/super_errors/fixtures/UntaggedNonUnary1.res new file mode 100644 index 0000000000..5143c46a1a --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/UntaggedNonUnary1.res @@ -0,0 +1,2 @@ +@unboxed +type t = Tuple(int, string) diff --git a/jscomp/build_tests/super_errors/fixtures/UntaggedNonUnary2.res b/jscomp/build_tests/super_errors/fixtures/UntaggedNonUnary2.res new file mode 100644 index 0000000000..fde4ae2799 --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/UntaggedNonUnary2.res @@ -0,0 +1,2 @@ +@unboxed +type t = Tuple(int, string) | Float(float) diff --git a/jscomp/build_tests/super_errors/fixtures/UntaggedUnknown.res b/jscomp/build_tests/super_errors/fixtures/UntaggedUnknown.res new file mode 100644 index 0000000000..2a043960fe --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/UntaggedUnknown.res @@ -0,0 +1,2 @@ +@unboxed +type t = Tuple((float, string)) | Float(float) From e8507ca8b5afc35c1cd57541e09db1248c14b5b0 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 7 Jun 2023 05:59:16 +0200 Subject: [PATCH 2/8] format --- jscomp/ml/ast_untagged_variants.ml | 441 +++++++++++++++-------------- 1 file changed, 234 insertions(+), 207 deletions(-) diff --git a/jscomp/ml/ast_untagged_variants.ml b/jscomp/ml/ast_untagged_variants.ml index b6d472be99..2e7ab68850 100644 --- a/jscomp/ml/ast_untagged_variants.ml +++ b/jscomp/ml/ast_untagged_variants.ml @@ -1,4 +1,11 @@ -type untaggedError = OnlyOneUnknown | AtMostOneObject | AtMostOneArray | AtMostOneFunction | AtMostOneString | AtMostOneNumber | DuplicateLiteral of string +type untaggedError = + | OnlyOneUnknown + | AtMostOneObject + | AtMostOneArray + | AtMostOneFunction + | AtMostOneString + | AtMostOneNumber + | DuplicateLiteral of string type error = | InvalidVariantAsAnnotation | Duplicated_bs_as @@ -10,27 +17,33 @@ let report_error ppf = let open Format in function | InvalidVariantAsAnnotation -> - fprintf ppf "A variant case annotation @as(...) must be a string or integer, \ - boolean, null, undefined" - | Duplicated_bs_as -> - fprintf ppf "duplicate @as " + fprintf ppf + "A variant case annotation @as(...) must be a string or integer, \ + boolean, null, undefined" + | Duplicated_bs_as -> fprintf ppf "duplicate @as " | InvalidVariantTagAnnotation -> fprintf ppf "A variant tag annotation @tag(...) must be a string" | InvalidUntaggedVariantDefinition untaggedVariant -> fprintf ppf "This untagged variant definition is invalid: %s" - (match untaggedVariant with - | OnlyOneUnknown -> "An unknown case must be the only case with payloads." - | AtMostOneObject -> "At most one case can be an object type." - | AtMostOneArray -> "At most one case can be an array type." - | AtMostOneFunction -> "At most one case can be a function type." - | AtMostOneString -> "At most one case can be a string type." - | AtMostOneNumber -> "At most one case can be a number type (int or float)." - | DuplicateLiteral s -> "Duplicate literal " ^ s ^ "." - ) + (match untaggedVariant with + | OnlyOneUnknown -> "An unknown case must be the only case with payloads." + | AtMostOneObject -> "At most one case can be an object type." + | AtMostOneArray -> "At most one case can be an array type." + | AtMostOneFunction -> "At most one case can be a function type." + | AtMostOneString -> "At most one case can be a string type." + | AtMostOneNumber -> + "At most one case can be a number type (int or float)." + | DuplicateLiteral s -> "Duplicate literal " ^ s ^ ".") (* Type of the runtime representation of an untagged block (case with payoad) *) type block_type = - | IntType | StringType | FloatType | ArrayType | FunctionType | ObjectType | UnknownType + | IntType + | StringType + | FloatType + | ArrayType + | FunctionType + | ObjectType + | UnknownType (* Type of the runtime representation of a tag. @@ -38,7 +51,12 @@ type block_type = In the case of block it can be tagged or untagged. *) type tag_type = - | String of string | Int of int | Float of string | Bool of bool | Null | Undefined (* literal or tagged block *) + | String of string + | Int of int + | Float of string + | Bool of bool + | Null + | Undefined (* literal or tagged block *) | Untagged of block_type (* untagged block *) type tag = {name: string; tag_type: tag_type option} type block = {tag: tag; tag_name: string option; block_type: block_type option} @@ -46,8 +64,8 @@ type switch_names = {consts: tag array; blocks: block array} let untagged = "unboxed" -let has_untagged (attrs: Parsetree.attributes) = - Ext_list.exists attrs (function ({txt}, _) -> txt = untagged) +let has_untagged (attrs : Parsetree.attributes) = + Ext_list.exists attrs (function {txt}, _ -> txt = untagged) let process_untagged (attrs : Parsetree.attributes) = let st = ref false in @@ -59,32 +77,26 @@ let process_untagged (attrs : Parsetree.attributes) = let process_tag_type (attrs : Parsetree.attributes) = let st : tag_type option ref = ref None in - Ext_list.iter attrs (fun (({txt; loc}, payload)) -> + Ext_list.iter attrs (fun ({txt; loc}, payload) -> match txt with | "bs.as" | "as" -> if !st = None then ( (match Ast_payload.is_single_string payload with | None -> () - | Some (s, _dec) -> - st := Some (String s)); + | Some (s, _dec) -> st := Some (String s)); (match Ast_payload.is_single_int payload with | None -> () - | Some i -> - st := Some (Int i)); + | Some i -> st := Some (Int i)); (match Ast_payload.is_single_float payload with | None -> () - | Some f -> - st := Some (Float f)); + | Some f -> st := Some (Float f)); (match Ast_payload.is_single_bool payload with | None -> () - | Some b -> - st := Some (Bool b)); + | Some b -> st := Some (Bool b)); (match Ast_payload.is_single_ident payload with | None -> () - | Some (Lident "null") -> - st := Some Null - | Some (Lident "undefined") -> - st := Some Undefined + | Some (Lident "null") -> st := Some Null + | Some (Lident "undefined") -> st := Some Undefined | Some _ -> raise (Error (loc, InvalidVariantAsAnnotation))); if !st = None then raise (Error (loc, InvalidVariantAsAnnotation))) else raise (Error (loc, Duplicated_bs_as)) @@ -92,78 +104,83 @@ let process_tag_type (attrs : Parsetree.attributes) = !st let () = - Location.register_error_of_exn - (function - | Error (loc, err) -> - Some (Location.error_of_printer loc report_error err) - | _ -> - None - ) + Location.register_error_of_exn (function + | Error (loc, err) -> Some (Location.error_of_printer loc report_error err) + | _ -> None) -let type_is_builtin_object (t:Types.type_expr) = match t.desc with - | Tconstr (path, _, _) -> - let name = Path.name path in - name = "Js.Dict.t" || name = "Js_dict.t" -| _ -> false +let type_is_builtin_object (t : Types.type_expr) = + match t.desc with + | Tconstr (path, _, _) -> + let name = Path.name path in + name = "Js.Dict.t" || name = "Js_dict.t" + | _ -> false -let get_block_type ~env (cstr: Types.constructor_declaration) : block_type option = - match process_untagged cstr.cd_attributes, cstr.cd_args with +let get_block_type ~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 -> - Some StringType - | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when Path.same path Predef.path_int -> - Some IntType - | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when Path.same path Predef.path_float -> - Some FloatType - | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when Path.same path Predef.path_array -> - Some ArrayType - | true, Cstr_tuple [{desc = Tconstr _} as t] when Ast_uncurried.typeIsUncurriedFun t -> - Some FunctionType - | true, Cstr_tuple [{desc = Tarrow _} ] -> - Some FunctionType - | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when Path. same path Predef.path_string -> - Some StringType - | true, Cstr_tuple [{desc = Tconstr _} as t] when type_is_builtin_object t -> - Some ObjectType - | true, Cstr_tuple [ty] -> + | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] + when Path.same path Predef.path_string -> + Some StringType + | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] + when Path.same path Predef.path_int -> + Some IntType + | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] + when Path.same path Predef.path_float -> + Some FloatType + | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] + when Path.same path Predef.path_array -> + Some ArrayType + | true, Cstr_tuple [({desc = Tconstr _} as t)] + when Ast_uncurried.typeIsUncurriedFun t -> + Some FunctionType + | true, Cstr_tuple [{desc = Tarrow _}] -> Some FunctionType + | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] + when Path.same path Predef.path_string -> + Some StringType + | true, Cstr_tuple [({desc = Tconstr _} as t)] when type_is_builtin_object t + -> + Some ObjectType + | true, Cstr_tuple [ty] -> ( let default = Some UnknownType in - (match Ctype.extract_concrete_typedecl env ty with - | (_, _, {type_kind = Type_record (_, Record_unboxed _)}) -> default - | (_, _, {type_kind = Type_record (_, _)}) -> Some ObjectType - | _ -> default - | exception _ -> default - ) -| true, Cstr_tuple (_ :: _ :: _) -> - (* C(_, _) with at least 2 args is an object *) - Some ObjectType + match Ctype.extract_concrete_typedecl env ty with + | _, _, {type_kind = Type_record (_, Record_unboxed _)} -> default + | _, _, {type_kind = Type_record (_, _)} -> Some ObjectType + | _ -> default + | exception _ -> default) + | true, Cstr_tuple (_ :: _ :: _) -> + (* C(_, _) with at least 2 args is an object *) + Some ObjectType | true, Cstr_record _ -> - (* inline record is an object *) - Some ObjectType + (* inline record is an object *) + Some ObjectType | true, _ -> None (* TODO: add restrictions here *) let process_tag_name (attrs : Parsetree.attributes) = let st = ref None in - Ext_list.iter attrs (fun (({txt; loc}, payload)) -> + 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))) + | Some (s, _dec) -> st := Some s); + if !st = None then raise (Error (loc, InvalidVariantTagAnnotation))) else raise (Error (loc, Duplicated_bs_as)) | _ -> ()); !st - -let get_tag_name (cstr: Types.constructor_declaration) = + +let get_tag_name (cstr : Types.constructor_declaration) = process_tag_name cstr.cd_attributes let is_nullary_variant (x : Types.constructor_arguments) = - match x with Types.Cstr_tuple [] -> true | _ -> false + match x with + | Types.Cstr_tuple [] -> true + | _ -> false -let checkInvariant ~isUntaggedDef ~(consts : (Location.t * tag) list) ~(blocks : (Location.t * block) list) = - let module StringSet = Set.Make(String) in +let checkInvariant ~isUntaggedDef ~(consts : (Location.t * tag) list) + ~(blocks : (Location.t * block) list) = + let module StringSet = Set.Make (String) in let string_literals = ref StringSet.empty in let nonstring_literals = ref StringSet.empty in let arrayTypes = ref 0 in @@ -172,75 +189,78 @@ let checkInvariant ~isUntaggedDef ~(consts : (Location.t * tag) list) ~(blocks : let stringTypes = ref 0 in let numberTypes = ref 0 in let unknownTypes = ref 0 in - let addStringLiteral ~loc s = + let addStringLiteral ~loc s = if StringSet.mem s !string_literals then raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))); - string_literals := StringSet.add s !string_literals in - let addNonstringLiteral ~loc s = + string_literals := StringSet.add s !string_literals + in + let addNonstringLiteral ~loc s = if StringSet.mem s !nonstring_literals then raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))); - nonstring_literals := StringSet.add s !nonstring_literals in + nonstring_literals := StringSet.add s !nonstring_literals + in let invariant loc = - if !unknownTypes <> 0 && (List.length blocks <> 1) - then raise (Error (loc, InvalidUntaggedVariantDefinition OnlyOneUnknown)); - if !objectTypes > 1 - then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneObject)); - if !arrayTypes > 1 - then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneArray)); - if !functionTypes > 1 - then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneFunction)); - if !stringTypes > 1 - then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneString)); - if !numberTypes > 1 - then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneNumber)); - () in - Ext_list.rev_iter consts (fun (loc, literal) -> match literal.tag_type with - | Some (String s) -> - addStringLiteral ~loc s - | Some (Int i) -> - addNonstringLiteral ~loc (string_of_int i) - | Some (Float f) -> - addNonstringLiteral ~loc f - | Some Null -> - addNonstringLiteral ~loc "null" - | Some Undefined -> - addNonstringLiteral ~loc "undefined" - | Some (Bool b) -> - addNonstringLiteral ~loc (if b then "true" else "false") - | Some (Untagged _) -> () - | None -> - addStringLiteral ~loc literal.name - ); + if !unknownTypes <> 0 && List.length blocks <> 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition OnlyOneUnknown)); + if !objectTypes > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneObject)); + if !arrayTypes > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneArray)); + if !functionTypes > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneFunction)); + if !stringTypes > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneString)); + if !numberTypes > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneNumber)); + () + in + Ext_list.rev_iter consts (fun (loc, literal) -> + match literal.tag_type with + | Some (String s) -> addStringLiteral ~loc s + | Some (Int i) -> addNonstringLiteral ~loc (string_of_int i) + | Some (Float f) -> addNonstringLiteral ~loc f + | Some Null -> addNonstringLiteral ~loc "null" + | Some Undefined -> addNonstringLiteral ~loc "undefined" + | Some (Bool b) -> + addNonstringLiteral ~loc (if b then "true" else "false") + | Some (Untagged _) -> () + | None -> addStringLiteral ~loc literal.name); if isUntaggedDef then - Ext_list.rev_iter blocks (fun (loc, block) -> match block.block_type with - | Some UnknownType -> - incr unknownTypes; - invariant loc - | Some ObjectType -> - incr objectTypes; - invariant loc - | Some ArrayType -> - incr arrayTypes; - invariant loc - | Some FunctionType -> - incr functionTypes; - invariant loc - | Some (IntType | FloatType) -> - incr numberTypes; - invariant loc - | Some StringType -> - incr stringTypes; - invariant loc - | None -> ()) + Ext_list.rev_iter blocks (fun (loc, block) -> + match block.block_type with + | Some UnknownType -> + incr unknownTypes; + invariant loc + | Some ObjectType -> + incr objectTypes; + invariant loc + | Some ArrayType -> + incr arrayTypes; + invariant loc + | Some FunctionType -> + incr functionTypes; + invariant loc + | Some (IntType | FloatType) -> + incr numberTypes; + invariant loc + | Some StringType -> + incr stringTypes; + invariant loc + | None -> ()) -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; - tag_type = process_tag_type cstr.cd_attributes }) in - let get_block (cstr: Types.constructor_declaration) : block = +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; + tag_type = process_tag_type cstr.cd_attributes; + } ) + in + let get_block (cstr : Types.constructor_declaration) : block = let tag = snd (get_cstr_name cstr) in - {tag; tag_name = get_tag_name cstr; block_type = get_block_type ~env cstr} in + {tag; tag_name = get_tag_name cstr; block_type = get_block_type ~env cstr} + in let consts, blocks = Ext_list.fold_left cstrs ([], []) (fun (consts, blocks) cstr -> if is_nullary_variant cstr.cd_args then @@ -252,23 +272,27 @@ let names_from_type_variant ?(isUntaggedDef=false) ~env (cstrs : Types.construct let consts = consts |> List.map snd in let consts = Ext_array.reverse_of_list consts in let blocks = Ext_array.reverse_of_list blocks in - Some { consts; blocks } + Some {consts; blocks} -let check_well_formed ~env ~isUntaggedDef (cstrs: Types.constructor_declaration list) = +let check_well_formed ~env ~isUntaggedDef + (cstrs : Types.constructor_declaration list) = ignore (names_from_type_variant ~env ~isUntaggedDef cstrs) -let has_undefined_literal attrs = - process_tag_type attrs = Some Undefined +let has_undefined_literal attrs = process_tag_type attrs = Some Undefined -let block_is_object ~env attrs = - get_block_type ~env attrs = Some ObjectType +let block_is_object ~env attrs = get_block_type ~env attrs = Some ObjectType module DynamicChecks = struct - type op = EqEqEq | NotEqEq | Or | And - type 'a t = BinOp of op * 'a t * 'a t | TagType of tag_type | TypeOf of 'a t | IsArray of 'a t | Not of 'a t | Expr of 'a + type 'a t = + | BinOp of op * 'a t * 'a t + | TagType of tag_type + | TypeOf of 'a t + | IsArray of 'a t + | Not of 'a t + | Expr of 'a - let bin op x y = BinOp(op, x, y) + let bin op x y = BinOp (op, x, y) let tag_type t = TagType t let typeof x = TypeOf x let str s = String s |> tag_type @@ -282,90 +306,93 @@ module DynamicChecks = struct let string = Untagged StringType |> tag_type let number = Untagged IntType |> tag_type - let (==) x y = bin EqEqEq x y - let (!=) x y = bin NotEqEq x y - let (|||) x y = bin Or x y - let (&&&) x y = bin And x y - + let ( == ) x y = bin EqEqEq x y + let ( != ) x y = bin NotEqEq x y + let ( ||| ) x y = bin Or x y + let ( &&& ) x y = bin And x y - let rec is_a_literal_case ~(literal_cases : tag_type list) ~block_cases (e: _ t) = - let literals_overlaps_with_string () = + let rec is_a_literal_case ~(literal_cases : tag_type list) ~block_cases + (e : _ t) = + let literals_overlaps_with_string () = Ext_list.exists literal_cases (function | String _ -> true - | _ -> false ) in - let literals_overlaps_with_number () = + | _ -> false) + in + let literals_overlaps_with_number () = Ext_list.exists literal_cases (function | Int _ | Float _ -> true - | _ -> false ) in - let literals_overlaps_with_object () = + | _ -> false) + in + let literals_overlaps_with_object () = Ext_list.exists literal_cases (function | Null -> true - | _ -> false ) in - let is_literal_case (t: tag_type) : _ t = e == (tag_type t) in - let is_not_block_case (c: block_type) : _ t = match c with - | StringType when literals_overlaps_with_string () = false (* No overlap *) -> - typeof e != string - | IntType when literals_overlaps_with_number () = false -> - typeof e != number - | FloatType when literals_overlaps_with_number () = false -> - typeof e != number - | ArrayType -> - not (is_array e) - | FunctionType -> - typeof e != function_ - | ObjectType when literals_overlaps_with_object () = false -> - typeof e != object_ - | ObjectType (* overlap *) -> - e == nil ||| (typeof e != object_) - | StringType (* overlap *) - | IntType (* overlap *) - | FloatType (* overlap *) - | UnknownType -> - (* We don't know the type of unknown, so we need to express: - this is not one of the literals *) - (match literal_cases with + | _ -> false) + in + let is_literal_case (t : tag_type) : _ t = e == tag_type t in + let is_not_block_case (c : block_type) : _ t = + match c with + | StringType + when literals_overlaps_with_string () = false (* No overlap *) -> + typeof e != string + | IntType when literals_overlaps_with_number () = false -> + typeof e != number + | FloatType when literals_overlaps_with_number () = false -> + typeof e != number + | ArrayType -> not (is_array e) + | FunctionType -> typeof e != function_ + | ObjectType when literals_overlaps_with_object () = false -> + typeof e != object_ + | ObjectType (* overlap *) -> e == nil ||| (typeof e != object_) + | StringType (* overlap *) + | IntType (* overlap *) + | FloatType (* overlap *) + | UnknownType -> ( + (* We don't know the type of unknown, so we need to express: + this is not one of the literals *) + match literal_cases with | [] -> (* this should not happen *) assert false | l1 :: others -> let is_literal_1 = is_literal_case l1 in Ext_list.fold_right others is_literal_1 (fun literal_n acc -> - (is_literal_case literal_n) ||| acc - ) - ) + is_literal_case literal_n ||| acc)) in match block_cases with | [c] -> is_not_block_case c - | c1 :: (_::_ as rest) -> - (is_not_block_case c1) &&& (is_a_literal_case ~literal_cases ~block_cases:rest e) + | c1 :: (_ :: _ as rest) -> + is_not_block_case c1 + &&& is_a_literal_case ~literal_cases ~block_cases:rest e | [] -> assert false - let is_int_tag ?(has_null_undefined_other=(false, false, false)) (e : _ t) : _ t = - let (has_null, has_undefined, has_other) = has_null_undefined_other in - if has_null && (has_undefined = false) && (has_other = false) then (* null *) + let is_int_tag ?(has_null_undefined_other = (false, false, false)) (e : _ t) : + _ t = + let has_null, has_undefined, has_other = has_null_undefined_other in + if has_null && has_undefined = false && has_other = false then + (* null *) bin EqEqEq e nil - else if has_null && has_undefined && has_other=false then (* null + undefined *) + else if has_null && has_undefined && has_other = false then + (* null + undefined *) e == nil ||| e == undefined - else if has_null=false && has_undefined && has_other=false then (* undefined *) - e == undefined - else if has_null then (* (null + undefined + other) || (null + other) *) + else if has_null = false && has_undefined && has_other = false then + (* undefined *) + e == undefined + else if has_null then + (* (null + undefined + other) || (null + other) *) e == nil ||| typeof e != object_ else (* (undefiled + other) || other *) typeof e != object_ - let add_runtime_type_check ~tag_type ~(block_cases: block_type list) x y = - let has_array() = Ext_list.exists block_cases (fun t -> t = ArrayType) in + let add_runtime_type_check ~tag_type ~(block_cases : block_type list) x y = + let has_array () = Ext_list.exists block_cases (fun t -> t = ArrayType) in match tag_type with | Untagged (IntType | StringType | FloatType | FunctionType) -> typeof y == x | Untagged ObjectType -> - if has_array() then - typeof y == x &&& not (is_array y) - else - typeof y == x + if has_array () then typeof y == x &&& not (is_array y) else typeof y == x | Untagged ArrayType -> is_array y | Untagged UnknownType -> (* This should not happen because unknown must be the only non-literal case *) - assert false + assert false | Bool _ | Float _ | Int _ | String _ | Null | Undefined -> x -end \ No newline at end of file +end From e1e2a91b1c2e7bfc092e1c045f08e3af85ef5831 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 7 Jun 2023 06:10:12 +0200 Subject: [PATCH 3/8] Better error message for constructor with more than one argument. --- .../expected/UntaggedNonUnary1.res.expected | 3 +-- jscomp/ml/ast_untagged_variants.ml | 7 ++++++- jscomp/ml/typedecl.ml | 15 +++++++-------- 3 files changed, 14 insertions(+), 11 deletions(-) diff --git a/jscomp/build_tests/super_errors/expected/UntaggedNonUnary1.res.expected b/jscomp/build_tests/super_errors/expected/UntaggedNonUnary1.res.expected index a03919db69..fd11bbf511 100644 --- a/jscomp/build_tests/super_errors/expected/UntaggedNonUnary1.res.expected +++ b/jscomp/build_tests/super_errors/expected/UntaggedNonUnary1.res.expected @@ -6,5 +6,4 @@ 2 │ type t = Tuple(int, string) 3 │ - This type cannot be unboxed because - its constructor has more than one argument. \ No newline at end of file + This untagged variant definition is invalid: Constructor Tuple has more than one argument. \ No newline at end of file diff --git a/jscomp/ml/ast_untagged_variants.ml b/jscomp/ml/ast_untagged_variants.ml index 2e7ab68850..6c4c6fdaec 100644 --- a/jscomp/ml/ast_untagged_variants.ml +++ b/jscomp/ml/ast_untagged_variants.ml @@ -6,6 +6,7 @@ type untaggedError = | AtMostOneString | AtMostOneNumber | DuplicateLiteral of string + | ConstructorMoreThanOneArg of string type error = | InvalidVariantAsAnnotation | Duplicated_bs_as @@ -33,7 +34,8 @@ let report_error ppf = | AtMostOneString -> "At most one case can be a string type." | AtMostOneNumber -> "At most one case can be a number type (int or float)." - | DuplicateLiteral s -> "Duplicate literal " ^ s ^ ".") + | DuplicateLiteral s -> "Duplicate literal " ^ s ^ "." + | ConstructorMoreThanOneArg (name) -> "Constructor " ^ name ^ " has more than one argument.") (* Type of the runtime representation of an untagged block (case with payoad) *) type block_type = @@ -108,6 +110,9 @@ let () = | Error (loc, err) -> Some (Location.error_of_printer loc report_error err) | _ -> None) +let reportConstructorMoreThanOneArg ~loc ~name = + raise (Error (loc, InvalidUntaggedVariantDefinition (ConstructorMoreThanOneArg name))) + let type_is_builtin_object (t : Types.type_expr) = match t.desc with | Tconstr (path, _, _) -> diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index b6de66a304..6438902797 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -319,18 +319,17 @@ let transl_declaration ~typeRecordAsObject env sdecl id = | Ptype_abstract -> raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute "it is abstract")) - | Ptype_variant [{pcd_args = Pcstr_tuple []; _}] -> + | Ptype_variant [{pcd_args = Pcstr_tuple []}] -> raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute "its constructor has no argument")) - | Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}] -> () - | Ptype_variant [{pcd_args = Pcstr_tuple _; _}] -> - raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute - "its constructor has more than one argument")) + | Ptype_variant [{pcd_args = Pcstr_tuple [_]}] -> () + | Ptype_variant [{pcd_args = Pcstr_tuple _; pcd_name = {txt=name}}] -> + Ast_untagged_variants.reportConstructorMoreThanOneArg ~loc:sdecl.ptype_loc ~name | Ptype_variant [{pcd_args = Pcstr_record - [{pld_mutable=Immutable; _}]; _}] -> () - | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Mutable; _}]; _}] -> + [{pld_mutable=Immutable; _}]}] -> () + | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Mutable; _}]}] -> raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute "it is mutable")) - | Ptype_variant [{pcd_args = Pcstr_record _; _}] -> + | Ptype_variant [{pcd_args = Pcstr_record _}] -> raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute "its constructor has more than one argument")) | Ptype_variant _ -> From 5cbf07993f9f254adbeef1dc2e3224255f17bf5f Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 7 Jun 2023 06:27:02 +0200 Subject: [PATCH 4/8] refactor: clarity --- jscomp/ml/typedecl.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index 6438902797..0532fc0010 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -323,7 +323,7 @@ let transl_declaration ~typeRecordAsObject env sdecl id = raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute "its constructor has no argument")) | Ptype_variant [{pcd_args = Pcstr_tuple [_]}] -> () - | Ptype_variant [{pcd_args = Pcstr_tuple _; pcd_name = {txt=name}}] -> + | Ptype_variant [{pcd_args = Pcstr_tuple (_::_::_); pcd_name = {txt=name}}] -> Ast_untagged_variants.reportConstructorMoreThanOneArg ~loc:sdecl.ptype_loc ~name | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Immutable; _}]}] -> () From 4cc15f7fc76a0dd1d8f1d33e80f0de157a4cb908 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 7 Jun 2023 06:37:09 +0200 Subject: [PATCH 5/8] Treat cases with non-unary payloads uniformly. --- .../expected/UntaggedNonUnary2.res.expected | 2 +- jscomp/ml/typedecl.ml | 12 ++++++------ 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/jscomp/build_tests/super_errors/expected/UntaggedNonUnary2.res.expected b/jscomp/build_tests/super_errors/expected/UntaggedNonUnary2.res.expected index 36f92991cb..220c6f689c 100644 --- a/jscomp/build_tests/super_errors/expected/UntaggedNonUnary2.res.expected +++ b/jscomp/build_tests/super_errors/expected/UntaggedNonUnary2.res.expected @@ -6,4 +6,4 @@ 2 │ type t = Tuple(int, string) | Float(float) 3 │ - This type cannot be unboxed because it has more than one constructor. \ No newline at end of file + This untagged variant definition is invalid: Constructor Tuple has more than one argument. \ No newline at end of file diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index 0532fc0010..ffafa2edd8 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -304,17 +304,19 @@ let transl_declaration ~typeRecordAsObject env sdecl id = in let raw_status = get_unboxed_from_attributes sdecl in - let checkUntaggedVariant = match sdecl.ptype_kind with + let checkUntaggedVariant() = match sdecl.ptype_kind with | Ptype_variant cds -> Ext_list.for_all cds (function | {pcd_args = Pcstr_tuple ([] | [_])} -> (* at most one payload allowed for untagged variants *) true + | {pcd_args = Pcstr_tuple (_::_::_); pcd_name={txt=name}} -> + Ast_untagged_variants.reportConstructorMoreThanOneArg ~loc:sdecl.ptype_loc ~name | {pcd_args = Pcstr_record _} -> true - | _ -> false ) + ) | _ -> false in - if raw_status.unboxed && not raw_status.default && not checkUntaggedVariant then begin + if raw_status.unboxed && not raw_status.default && not (checkUntaggedVariant()) then begin match sdecl.ptype_kind with | Ptype_abstract -> raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute @@ -322,9 +324,7 @@ let transl_declaration ~typeRecordAsObject env sdecl id = | Ptype_variant [{pcd_args = Pcstr_tuple []}] -> raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute "its constructor has no argument")) - | Ptype_variant [{pcd_args = Pcstr_tuple [_]}] -> () - | Ptype_variant [{pcd_args = Pcstr_tuple (_::_::_); pcd_name = {txt=name}}] -> - Ast_untagged_variants.reportConstructorMoreThanOneArg ~loc:sdecl.ptype_loc ~name + | Ptype_variant [{pcd_args = Pcstr_tuple _}] -> () | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Immutable; _}]}] -> () | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Mutable; _}]}] -> From 2fd52561e886e1e6244d5764ad584abc99a8fc9f Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 7 Jun 2023 06:47:07 +0200 Subject: [PATCH 6/8] Remove unused cases. --- jscomp/ml/typedecl.ml | 15 +-------------- 1 file changed, 1 insertion(+), 14 deletions(-) diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index ffafa2edd8..305ae852ca 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -321,20 +321,7 @@ let transl_declaration ~typeRecordAsObject env sdecl id = | Ptype_abstract -> raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute "it is abstract")) - | Ptype_variant [{pcd_args = Pcstr_tuple []}] -> - raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute - "its constructor has no argument")) - | Ptype_variant [{pcd_args = Pcstr_tuple _}] -> () - | Ptype_variant [{pcd_args = Pcstr_record - [{pld_mutable=Immutable; _}]}] -> () - | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Mutable; _}]}] -> - raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute "it is mutable")) - | Ptype_variant [{pcd_args = Pcstr_record _}] -> - raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute - "its constructor has more than one argument")) - | Ptype_variant _ -> - raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute - "it has more than one constructor")) + | Ptype_variant _ -> () | Ptype_record [{pld_mutable=Immutable; _}] -> () | Ptype_record [{pld_mutable=Mutable; _}] -> raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute From 249a0e45e72e08ac5b88d49f071528517437173a Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 7 Jun 2023 07:06:11 +0200 Subject: [PATCH 7/8] Improve error message for unknown case. --- .../expected/UntaggedUnknown.res.expected | 2 +- jscomp/ml/ast_untagged_variants.ml | 21 ++++++++++--------- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/jscomp/build_tests/super_errors/expected/UntaggedUnknown.res.expected b/jscomp/build_tests/super_errors/expected/UntaggedUnknown.res.expected index 8acc7cc3bb..a961530af3 100644 --- a/jscomp/build_tests/super_errors/expected/UntaggedUnknown.res.expected +++ b/jscomp/build_tests/super_errors/expected/UntaggedUnknown.res.expected @@ -6,4 +6,4 @@ 2 │ type t = Tuple((float, string)) | Float(float) 3 │ - This untagged variant definition is invalid: An unknown case must be the only case with payloads. \ No newline at end of file + This untagged variant definition is invalid: Case Tuple has a payload that is not of one of the recognized shapes (object, array, etc). Then it must be the only case with payloads. \ No newline at end of file diff --git a/jscomp/ml/ast_untagged_variants.ml b/jscomp/ml/ast_untagged_variants.ml index 6c4c6fdaec..ef686d1f2e 100644 --- a/jscomp/ml/ast_untagged_variants.ml +++ b/jscomp/ml/ast_untagged_variants.ml @@ -1,5 +1,5 @@ type untaggedError = - | OnlyOneUnknown + | OnlyOneUnknown of string | AtMostOneObject | AtMostOneArray | AtMostOneFunction @@ -27,7 +27,7 @@ let report_error ppf = | InvalidUntaggedVariantDefinition untaggedVariant -> fprintf ppf "This untagged variant definition is invalid: %s" (match untaggedVariant with - | OnlyOneUnknown -> "An unknown case must be the only case with payloads." + | OnlyOneUnknown name -> "Case " ^ name ^ " has a payload that is not of one of the recognized shapes (object, array, etc). Then it must be the only case with payloads." | AtMostOneObject -> "At most one case can be an object type." | AtMostOneArray -> "At most one case can be an array type." | AtMostOneFunction -> "At most one case can be a function type." @@ -204,9 +204,9 @@ let checkInvariant ~isUntaggedDef ~(consts : (Location.t * tag) list) raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))); nonstring_literals := StringSet.add s !nonstring_literals in - let invariant loc = + let invariant loc name = if !unknownTypes <> 0 && List.length blocks <> 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition OnlyOneUnknown)); + raise (Error (loc, InvalidUntaggedVariantDefinition (OnlyOneUnknown name))); if !objectTypes > 1 then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneObject)); if !arrayTypes > 1 then @@ -232,25 +232,26 @@ let checkInvariant ~isUntaggedDef ~(consts : (Location.t * tag) list) | None -> addStringLiteral ~loc literal.name); if isUntaggedDef then Ext_list.rev_iter blocks (fun (loc, block) -> + let name = block.tag.name in match block.block_type with | Some UnknownType -> incr unknownTypes; - invariant loc + invariant loc name | Some ObjectType -> incr objectTypes; - invariant loc + invariant loc name | Some ArrayType -> incr arrayTypes; - invariant loc + invariant loc name | Some FunctionType -> incr functionTypes; - invariant loc + invariant loc name | Some (IntType | FloatType) -> incr numberTypes; - invariant loc + invariant loc name | Some StringType -> incr stringTypes; - invariant loc + invariant loc name | None -> ()) let names_from_type_variant ?(isUntaggedDef = false) ~env From e81b7529da154c5270de0d91b1ba4bd9a8266add Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 7 Jun 2023 09:22:48 +0200 Subject: [PATCH 8/8] Update CHANGELOG.md Fixes https://github.com/rescript-lang/rescript-compiler/issues/6272 --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 268a506a2a..2ec3e6bac6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -24,6 +24,7 @@ #### :bug: Bug Fix - Fix issue where uncurried type internals leak in type error. https://github.com/rescript-lang/rescript-compiler/pull/6264 +- Improve error messages for untagged variant definitions https://github.com/rescript-lang/rescript-compiler/pull/6290 # 11.0.0-beta.1