Skeleton adapt untagged variants to several instanceof cases.

Author: cristianoc

jscomp/core/js_exp_make.ml

@@ -807,7 +807,7 @@ let tag_type = function
   | Untagged FloatType -> str "number"
   | Untagged FunctionType -> str "function"
   | Untagged StringType -> str "string"
-  | Untagged ArrayType -> str "Array" ~delim:DNoQuotes
+  | Untagged (InstanceType i) -> str (Ast_untagged_variants.Instance.to_string i) ~delim:DNoQuotes
   | Untagged ObjectType -> str "object"
   | Untagged UnknownType ->
     (* TODO: this should not happen *)
@@ -824,7 +824,10 @@ let rec emit_check (check : t Ast_untagged_variants.DynamicChecks.t) = match che
     in
     bin op (emit_check x) (emit_check y)
   | TypeOf x -> typeof (emit_check x)
-  | IsArray x -> is_array (emit_check x)
+  | IsInstanceOf (Array, x) -> is_array (emit_check x)
+  | IsInstanceOf (instance, x) ->
+    let instance_name = Ast_untagged_variants.Instance.to_string instance in
+    instanceof (emit_check x) (str instance_name ~delim:DNoQuotes) 
   | Not x -> not (emit_check x)
   | Expr x -> x
 

jscomp/core/lam_compile.ml

@@ -762,7 +762,7 @@ and compile_untagged_cases ~cxt ~switch_exp ~default ~block_cases cases =
     in
     E.emit_check check
   in
-  let is_array (l, _) = l = Ast_untagged_variants.Untagged ArrayType in
+  let is_array (l, _) = l = Ast_untagged_variants.Untagged (InstanceType Array) in
   let switch ?default ?declaration e clauses =
     let array_clauses = Ext_list.filter clauses is_array in
     match array_clauses with

jscomp/ml/ast_untagged_variants.ml

@@ -1,7 +1,12 @@
+module Instance = struct
+  type t = Array | Promise
+  let to_string = function Array -> "Array" | Promise -> "Promise"
+end
+
 type untaggedError =
   | OnlyOneUnknown of string
   | AtMostOneObject
-  | AtMostOneArray
+  | AtMostOneInstance of Instance.t
   | AtMostOneFunction
   | AtMostOneString
   | AtMostOneNumber
@@ -29,7 +34,7 @@ let report_error ppf =
       (match untaggedVariant with
       | 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."
+      | AtMostOneInstance i -> "At most one case can be a " ^ (Instance.to_string i) ^ " type."
       | AtMostOneFunction -> "At most one case can be a function type."
       | AtMostOneString -> "At most one case can be a string type."
       | AtMostOneNumber ->
@@ -42,7 +47,7 @@ type block_type =
   | IntType
   | StringType
   | FloatType
-  | ArrayType
+  | InstanceType of Instance.t
   | FunctionType
   | ObjectType
   | UnknownType
@@ -139,7 +144,10 @@ let get_block_type ~env (cstr : Types.constructor_declaration) :
     Some FloatType
   | true, Cstr_tuple [{desc = Tconstr (path, _, _)}]
     when Path.same path Predef.path_array ->
-    Some ArrayType
+    Some (InstanceType Array)
+  | true, Cstr_tuple [{desc = Tconstr (path, _, _)}]
+    when Path.same path Predef.path_promise ->
+    Some (InstanceType Promise)
   | true, Cstr_tuple [({desc = Tconstr _} as t)]
     when Ast_uncurried_utils.typeIsUncurriedFun t ->
     Some FunctionType
@@ -192,7 +200,7 @@ let checkInvariant ~isUntaggedDef ~(consts : (Location.t * tag) 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
+  let instanceTypes = Hashtbl.create 1 in
   let functionTypes = ref 0 in
   let objectTypes = ref 0 in
   let stringTypes = ref 0 in
@@ -213,8 +221,10 @@ let checkInvariant ~isUntaggedDef ~(consts : (Location.t * tag) list)
       raise (Error (loc, InvalidUntaggedVariantDefinition (OnlyOneUnknown name)));
     if !objectTypes > 1 then
       raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneObject));
-    if !arrayTypes > 1 then
-      raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneArray));
+    Hashtbl.iter (fun i count ->
+        if count > 1 then
+          raise (Error (loc, InvalidUntaggedVariantDefinition (AtMostOneInstance i))))
+      instanceTypes;
     if !functionTypes > 1 then
       raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneFunction));
     if !stringTypes > 1 then
@@ -244,8 +254,9 @@ let checkInvariant ~isUntaggedDef ~(consts : (Location.t * tag) list)
         | Some ObjectType ->
           incr objectTypes;
           invariant loc name
-        | Some ArrayType ->
-          incr arrayTypes;
+        | Some (InstanceType i) ->
+          let count = Hashtbl.find_opt instanceTypes i |> Option.value ~default:0 in
+          Hashtbl.replace instanceTypes i (count + 1);
           invariant loc name
         | Some FunctionType ->
           incr functionTypes;
@@ -298,15 +309,15 @@ module DynamicChecks = struct
     | BinOp of op * 'a t * 'a t
     | TagType of tag_type
     | TypeOf of 'a t
-    | IsArray of 'a t
+    | IsInstanceOf of Instance.t * 'a t
     | Not of 'a t
     | Expr of 'a
 
   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
-  let is_array x = IsArray x
+  let is_instance i x = IsInstanceOf (i, x)
   let not x = Not x
   let nil = Null |> tag_type
   let undefined = Undefined |> tag_type
@@ -348,7 +359,7 @@ module DynamicChecks = struct
         typeof e != number
       | FloatType when literals_overlaps_with_number () = false ->
         typeof e != number
-      | ArrayType -> not (is_array e)
+      | InstanceType i -> not (is_instance i e)
       | FunctionType -> typeof e != function_
       | ObjectType when literals_overlaps_with_object () = false ->
         typeof e != object_
@@ -394,13 +405,18 @@ module DynamicChecks = struct
       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 instances = Ext_list.filter_map block_cases (function InstanceType i -> Some i | _ -> None) 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
-    | Untagged ArrayType -> is_array y
+      if instances <> [] then
+         let not_one_of_the_instances =
+          Ext_list.fold_right instances (typeof y == x) (fun i x -> x &&& not (is_instance i y))  in
+         not_one_of_the_instances
+      else
+        typeof y == x
+    | Untagged (InstanceType i) -> is_instance i y
     | Untagged UnknownType ->
       (* This should not happen because unknown must be the only non-literal case *)
       assert false