diff --git a/jscomp/core/js_exp_make.ml b/jscomp/core/js_exp_make.ml index 8ddd08e52e..06d8ef1792 100644 --- a/jscomp/core/js_exp_make.ml +++ b/jscomp/core/js_exp_make.ml @@ -770,6 +770,7 @@ let tag_type = function | Untagged IntType -> str "number" | Untagged FloatType -> str "number" | Untagged StringType -> str "string" + | Untagged BoolType -> str "boolean" | Untagged ArrayType -> str "Array" ~delim:DNoQuotes | Untagged ObjectType -> str "object" | Untagged UnknownType -> diff --git a/jscomp/ml/ast_untagged_variants.ml b/jscomp/ml/ast_untagged_variants.ml index 0708f558ee..f46a859b7a 100644 --- a/jscomp/ml/ast_untagged_variants.ml +++ b/jscomp/ml/ast_untagged_variants.ml @@ -1,4 +1,4 @@ -type untaggedError = OnlyOneUnknown | AtMostOneObject | AtMostOneArray | AtMostOneString | AtMostOneNumber | DuplicateLiteral of string +type untaggedError = OnlyOneUnknown | AtMostOneObject | AtMostOneBool | AtMostOneArray | AtMostOneString | AtMostOneNumber | DuplicateLiteral of string type error = | InvalidVariantAsAnnotation | Duplicated_bs_as @@ -24,12 +24,13 @@ let report_error ppf = | AtMostOneArray -> "At most one case can be an array type." | AtMostOneString -> "At most one case can be a string type." | AtMostOneNumber -> "At most one case can be a number type (int or float)." + | AtMostOneBool -> "At most one case can be a boolean type." | DuplicateLiteral s -> "Duplicate literal " ^ s ^ "." ) (* Type of the runtime representation of an untagged block (case with payoad) *) type block_type = - | IntType | StringType | FloatType | ArrayType | ObjectType | UnknownType + | IntType | StringType | FloatType | BoolType | ArrayType | ObjectType | UnknownType (* Type of the runtime representation of a tag. @@ -110,8 +111,10 @@ let get_block_type ~env (cstr: Types.constructor_declaration) : block_type optio Some FloatType | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when Path.same path Predef.path_array -> Some ArrayType - | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when Path. same path Predef.path_string -> + | 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_bool -> + Some BoolType | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when let name = Path.name path in name = "Js.Dict.t" || name = "Js_dict.t" -> @@ -161,6 +164,7 @@ let checkInvariant ~isUntaggedDef ~(consts : (Location.t * tag) list) ~(blocks : let objectTypes = ref 0 in let stringTypes = ref 0 in let numberTypes = ref 0 in + let boolTypes = ref 0 in let unknownTypes = ref 0 in let addStringLiteral ~loc s = if StringSet.mem s !string_literals then @@ -179,6 +183,8 @@ let checkInvariant ~isUntaggedDef ~(consts : (Location.t * tag) list) ~(blocks : then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneArray)); if !stringTypes > 1 then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneString)); + if !boolTypes > 1 + then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBool)); if !numberTypes > 1 then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneNumber)); () in @@ -207,6 +213,9 @@ let checkInvariant ~isUntaggedDef ~(consts : (Location.t * tag) list) ~(blocks : | Some ObjectType -> incr objectTypes; invariant loc + | Some BoolType -> + incr boolTypes; + invariant loc | Some ArrayType -> incr arrayTypes; invariant loc @@ -258,6 +267,7 @@ module DynamicChecks = struct let object_ = Untagged ObjectType |> tag_type let string = Untagged StringType |> tag_type let number = Untagged IntType |> tag_type + let bool = Untagged BoolType |> tag_type let (==) x y = bin EqEqEq x y let (!=) x y = bin NotEqEq x y @@ -274,6 +284,10 @@ module DynamicChecks = struct Ext_list.exists literal_cases (function | Int _ | Float _ -> true | _ -> false ) in + let literals_overlaps_with_bool () = + Ext_list.exists literal_cases (function + | Bool _ -> true + | _ -> false ) in let literals_overlaps_with_object () = Ext_list.exists literal_cases (function | Null -> true @@ -286,6 +300,8 @@ module DynamicChecks = struct typeof e != number | FloatType when literals_overlaps_with_number () = false -> typeof e != number + | BoolType when literals_overlaps_with_bool () = false -> + typeof e != bool | ArrayType -> not (is_array e) | ObjectType when literals_overlaps_with_object () = false -> @@ -295,6 +311,7 @@ module DynamicChecks = struct | StringType (* overlap *) | IntType (* overlap *) | FloatType (* overlap *) + | BoolType (* overlap *) | UnknownType -> (* We don't know the type of unknown, so we need to express: this is not one of the literals *) @@ -333,6 +350,7 @@ module DynamicChecks = struct match tag_type with | Untagged IntType | Untagged StringType + | Untagged BoolType | Untagged FloatType -> typeof y == x | Untagged ObjectType -> if has_array() then diff --git a/jscomp/test/UntaggedVariants.js b/jscomp/test/UntaggedVariants.js index 97f82d7694..3a0cda95c5 100644 --- a/jscomp/test/UntaggedVariants.js +++ b/jscomp/test/UntaggedVariants.js @@ -145,6 +145,8 @@ function classify$4(x) { return "string"; case "number" : return "int"; + case "boolean" : + return "bool"; case "object" : return "Object" + x.name; diff --git a/jscomp/test/UntaggedVariants.res b/jscomp/test/UntaggedVariants.res index 6077501b70..62f5040235 100644 --- a/jscomp/test/UntaggedVariants.res +++ b/jscomp/test/UntaggedVariants.res @@ -110,12 +110,13 @@ module MultipleBlocks = { module OnlyBlocks = { @unboxed - type t<'a> = String(string) | Int(int) | Object({name: string}) + type t<'a> = String(string) | Int(int) | Boolean(bool) | Object({name: string}) let classify = x => switch x { | String(_) => "string" | Int(_) => "int" + | Boolean(_) => "bool" | Object({name}) => "Object" ++ name } }