rescript-lang · zth · Sep 7, 2023 · Sep 5, 2023 · Sep 5, 2023 · Sep 5, 2023
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -15,6 +15,8 @@
 #### :rocket: New Feature
 
 - Support renaming fields in inline records with `@as` attribute. [#6391](https://github.com/rescript-lang/rescript-compiler/pull/6391)
+- Add builtin abstract types for File and Blob APIs. https://github.com/rescript-lang/rescript-compiler/pull/6383
+- Untagged variants: Support `promise`, RegExes, Dates, File and Blob. https://github.com/rescript-lang/rescript-compiler/pull/6383
 
 # 11.0.0-rc.3
 

diff --git a/jscomp/core/js_exp_make.ml b/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
 

diff --git a/jscomp/core/lam_compile.ml b/jscomp/core/lam_compile.ml
@@ -762,18 +762,18 @@ 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_not_typeof (l, _) = match l with 
+  | Ast_untagged_variants.Untagged (InstanceType _) -> true
+  | _ -> false in
   let switch ?default ?declaration e clauses =
-    let array_clauses = Ext_list.filter clauses is_array in
-    match array_clauses with
-    | [(l, {J.switch_body})] when List.length clauses > 1 ->
-      let rest = Ext_list.filter clauses (fun c -> not (is_array c)) in
-      S.if_ (E.is_array e)
+    let (not_typeof_clauses, typeof_clauses) = List.partition is_not_typeof clauses in
+    let rec build_if_chain remaining_clauses = (match remaining_clauses with 
+    | (Ast_untagged_variants.Untagged (InstanceType instanceType), {J.switch_body}) :: rest -> 
+      S.if_ (E.emit_check (IsInstanceOf (instanceType, Expr e)))
         (switch_body)
-        ~else_:([S.string_switch ?default ?declaration (E.typeof e) rest])
-    | _ :: _ :: _ -> assert false (* at most 1 array case *)
-    | _ ->
-      S.string_switch ?default ?declaration (E.typeof e) clauses in
+        ~else_:([build_if_chain rest])
+    | _ -> S.string_switch ?default ?declaration (E.typeof e) typeof_clauses) in
+    build_if_chain not_typeof_clauses in
   cases |> compile_general_cases
     ~make_exp: E.tag_type
     ~eq_exp: mk_eq

diff --git a/jscomp/ml/ast_untagged_variants.ml b/jscomp/ml/ast_untagged_variants.ml
@@ -1,7 +1,24 @@
+module Instance = struct
+  type t = 
+    | Array
+    | Blob
+    | Date
+    | File
+    | Promise 
+    | RegExp
+  let to_string = function
+      Array -> "Array" 
+    | Blob -> "Blob"
+    | Date -> "Date"
+    | File -> "File"
+    | Promise -> "Promise" 
+    | RegExp -> "RegExp"
+end
+
 type untaggedError =
   | OnlyOneUnknown of string
   | AtMostOneObject
-  | AtMostOneArray
+  | AtMostOneInstance of Instance.t
   | AtMostOneFunction
   | AtMostOneString
   | AtMostOneNumber
@@ -29,7 +46,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 +59,7 @@ type block_type =
   | IntType
   | StringType
   | FloatType
-  | ArrayType
+  | InstanceType of Instance.t
   | FunctionType
   | ObjectType
   | UnknownType
@@ -121,9 +138,26 @@ 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" || name = "Js.Re.t" || name = "RescriptCore.Re.t"
+    name = "Js.Dict.t" || name = "Js_dict.t"
   | _ -> false
 
+let type_to_instanceof_backed_obj (t : Types.type_expr) =
+  match t.desc with
+  | Tconstr (path, _, _) when Path.same path Predef.path_promise ->
+    Some Instance.Promise
+  | Tconstr (path, _, _) when Path.same path Predef.path_array ->
+    Some Array
+  | Tconstr (path, _, _) -> (
+    match Path.name path with
+    | "Js.Date.t" | "Js_date.t" -> Some(Date)
+    | "Js.Re.t" | "Js_re.t" | "RescriptCore.Re.t" -> 
+      (* TODO: Get rid of explicit Core by digging through aliases *) 
+      Some(RegExp)
+    | "Js.File.t" | "Js_file.t" -> Some(File)
+    | "Js.Blob.t" | "Js_blob.t" -> Some(Blob)
+    | _ -> None)
+  | _ -> None
+
 let get_block_type ~env (cstr : Types.constructor_declaration) :
     block_type option =
   match (process_untagged cstr.cd_attributes, cstr.cd_args) with
@@ -137,9 +171,6 @@ let get_block_type ~env (cstr : Types.constructor_declaration) :
   | 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_utils.typeIsUncurriedFun t ->
     Some FunctionType
@@ -150,6 +181,11 @@ let get_block_type ~env (cstr : Types.constructor_declaration) :
   | true, Cstr_tuple [({desc = Tconstr _} as t)] when type_is_builtin_object t
     ->
     Some ObjectType
+  | true, Cstr_tuple [({desc = Tconstr _} as t)] when type_to_instanceof_backed_obj t |> Option.is_some
+    ->
+    (match type_to_instanceof_backed_obj t with 
+    | None -> None 
+    | Some instanceType -> Some (InstanceType instanceType))
   | true, Cstr_tuple [ty] -> (
     let default = Some UnknownType in
     match !extract_concrete_typedecl env ty with
@@ -192,7 +228,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 +249,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 +282,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 +337,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 +387,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 +433,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

diff --git a/jscomp/others/js.ml b/jscomp/others/js.ml
@@ -261,6 +261,12 @@ module Int = Js_int
 module Bigint = Js_bigint
 (** Provide utilities for bigint *)
 
+module File = Js_file
+(** Provide utilities for File *)
+
+module Blob = Js_blob
+(** Provide utilities for Blob *)
+
 module Option = Js_option
 (** Provide utilities for option *)
 

diff --git a/jscomp/others/js_blob.res b/jscomp/others/js_blob.res
@@ -0,0 +1,3 @@
+/*** JavaScript Blob API */
+
+type t
diff --git a/jscomp/others/js_file.res b/jscomp/others/js_file.res
@@ -0,0 +1,3 @@
+/*** JavaScript File API */
+
+type t
diff --git a/jscomp/others/release.ninja b/jscomp/others/release.ninja
@@ -19,6 +19,7 @@ o others/js_OO.cmi others/js_OO.cmj : cc others/js_OO.res | others/belt_internal
 o others/js_array.cmi others/js_array.cmj : cc others/js_array.res | others/belt_internals.cmi others/js.cmi others/js_array2.cmj $bsc
 o others/js_array2.cmi others/js_array2.cmj : cc others/js_array2.res | others/belt_internals.cmi others/js.cmi $bsc
 o others/js_bigint.cmi others/js_bigint.cmj : cc others/js_bigint.res | others/belt_internals.cmi others/js.cmi $bsc
+o others/js_blob.cmi others/js_blob.cmj : cc others/js_blob.res | others/belt_internals.cmi others/js.cmi $bsc
 o others/js_cast.cmj : cc_cmi others/js_cast.res | others/belt_internals.cmi others/js.cmi others/js_cast.cmi $bsc
 o others/js_cast.cmi : cc others/js_cast.resi | others/belt_internals.cmi others/js.cmi $bsc
 o others/js_console.cmi others/js_console.cmj : cc others/js_console.res | others/belt_internals.cmi others/js.cmi $bsc
@@ -27,6 +28,7 @@ o others/js_dict.cmj : cc_cmi others/js_dict.res | others/belt_internals.cmi oth
 o others/js_dict.cmi : cc others/js_dict.resi | others/belt_internals.cmi others/js.cmi $bsc
 o others/js_exn.cmj : cc_cmi others/js_exn.res | others/belt_internals.cmi others/js.cmi others/js_exn.cmi $bsc
 o others/js_exn.cmi : cc others/js_exn.resi | others/belt_internals.cmi others/js.cmi $bsc
+o others/js_file.cmi others/js_file.cmj : cc others/js_file.res | others/belt_internals.cmi others/js.cmi $bsc
 o others/js_float.cmi others/js_float.cmj : cc others/js_float.res | others/belt_internals.cmi others/js.cmi $bsc
 o others/js_global.cmi others/js_global.cmj : cc others/js_global.res | others/belt_internals.cmi others/js.cmi $bsc
 o others/js_int.cmi others/js_int.cmj : cc others/js_int.res | others/belt_internals.cmi others/js.cmi $bsc
@@ -72,7 +74,7 @@ o others/jsxEventU.cmi others/jsxEventU.cmj : cc others/jsxEventU.res | others/b
 o others/jsxPPXReactSupportC.cmi others/jsxPPXReactSupportC.cmj : cc others/jsxPPXReactSupportC.res | others/belt_internals.cmi others/js.cmi others/jsxC.cmj $bsc
 o others/jsxPPXReactSupportU.cmi others/jsxPPXReactSupportU.cmj : cc others/jsxPPXReactSupportU.res | others/belt_internals.cmi others/js.cmi others/jsxU.cmj $bsc
 o others/jsxU.cmi others/jsxU.cmj : cc others/jsxU.res | others/belt_internals.cmi others/js.cmi $bsc
-o js_pkg : phony others/js_OO.cmi others/js_OO.cmj others/js_array.cmi others/js_array.cmj others/js_array2.cmi others/js_array2.cmj others/js_bigint.cmi others/js_bigint.cmj others/js_cast.cmi others/js_cast.cmj others/js_console.cmi others/js_console.cmj others/js_date.cmi others/js_date.cmj others/js_dict.cmi others/js_dict.cmj others/js_exn.cmi others/js_exn.cmj others/js_float.cmi others/js_float.cmj others/js_global.cmi others/js_global.cmj others/js_int.cmi others/js_int.cmj others/js_json.cmi others/js_json.cmj others/js_list.cmi others/js_list.cmj others/js_map.cmi others/js_map.cmj others/js_mapperRt.cmi others/js_mapperRt.cmj others/js_math.cmi others/js_math.cmj others/js_null.cmi others/js_null.cmj others/js_null_undefined.cmi others/js_null_undefined.cmj others/js_obj.cmi others/js_obj.cmj others/js_option.cmi others/js_option.cmj others/js_promise.cmi others/js_promise.cmj others/js_promise2.cmi others/js_promise2.cmj others/js_re.cmi others/js_re.cmj others/js_result.cmi others/js_result.cmj others/js_set.cmi others/js_set.cmj others/js_string.cmi others/js_string.cmj others/js_string2.cmi others/js_string2.cmj others/js_typed_array.cmi others/js_typed_array.cmj others/js_typed_array2.cmi others/js_typed_array2.cmj others/js_types.cmi others/js_types.cmj others/js_undefined.cmi others/js_undefined.cmj others/js_vector.cmi others/js_vector.cmj others/js_weakmap.cmi others/js_weakmap.cmj others/js_weakset.cmi others/js_weakset.cmj others/jsxC.cmi others/jsxC.cmj others/jsxDOMC.cmi others/jsxDOMC.cmj others/jsxDOMStyle.cmi others/jsxDOMStyle.cmj others/jsxDOMU.cmi others/jsxDOMU.cmj others/jsxEventC.cmi others/jsxEventC.cmj others/jsxEventU.cmi others/jsxEventU.cmj others/jsxPPXReactSupportC.cmi others/jsxPPXReactSupportC.cmj others/jsxPPXReactSupportU.cmi others/jsxPPXReactSupportU.cmj others/jsxU.cmi others/jsxU.cmj
+o js_pkg : phony others/js_OO.cmi others/js_OO.cmj others/js_array.cmi others/js_array.cmj others/js_array2.cmi others/js_array2.cmj others/js_bigint.cmi others/js_bigint.cmj others/js_blob.cmi others/js_blob.cmj others/js_cast.cmi others/js_cast.cmj others/js_console.cmi others/js_console.cmj others/js_date.cmi others/js_date.cmj others/js_dict.cmi others/js_dict.cmj others/js_exn.cmi others/js_exn.cmj others/js_file.cmi others/js_file.cmj others/js_float.cmi others/js_float.cmj others/js_global.cmi others/js_global.cmj others/js_int.cmi others/js_int.cmj others/js_json.cmi others/js_json.cmj others/js_list.cmi others/js_list.cmj others/js_map.cmi others/js_map.cmj others/js_mapperRt.cmi others/js_mapperRt.cmj others/js_math.cmi others/js_math.cmj others/js_null.cmi others/js_null.cmj others/js_null_undefined.cmi others/js_null_undefined.cmj others/js_obj.cmi others/js_obj.cmj others/js_option.cmi others/js_option.cmj others/js_promise.cmi others/js_promise.cmj others/js_promise2.cmi others/js_promise2.cmj others/js_re.cmi others/js_re.cmj others/js_result.cmi others/js_result.cmj others/js_set.cmi others/js_set.cmj others/js_string.cmi others/js_string.cmj others/js_string2.cmi others/js_string2.cmj others/js_typed_array.cmi others/js_typed_array.cmj others/js_typed_array2.cmi others/js_typed_array2.cmj others/js_types.cmi others/js_types.cmj others/js_undefined.cmi others/js_undefined.cmj others/js_vector.cmi others/js_vector.cmj others/js_weakmap.cmi others/js_weakmap.cmj others/js_weakset.cmi others/js_weakset.cmj others/jsxC.cmi others/jsxC.cmj others/jsxDOMC.cmi others/jsxDOMC.cmj others/jsxDOMStyle.cmi others/jsxDOMStyle.cmj others/jsxDOMU.cmi others/jsxDOMU.cmj others/jsxEventC.cmi others/jsxEventC.cmj others/jsxEventU.cmi others/jsxEventU.cmj others/jsxPPXReactSupportC.cmi others/jsxPPXReactSupportC.cmj others/jsxPPXReactSupportU.cmi others/jsxPPXReactSupportU.cmj others/jsxU.cmi others/jsxU.cmj
 o others/belt_Array.cmj : cc_cmi others/belt_Array.res | others/belt.cmi others/belt_Array.cmi others/belt_internals.cmi others/js.cmi others/js.cmj others/js_math.cmj $bsc js_pkg
 o others/belt_Array.cmi : cc others/belt_Array.resi | others/belt.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg
 o others/belt_Float.cmj : cc_cmi others/belt_Float.res | others/belt.cmi others/belt_Float.cmi others/belt_internals.cmi others/js.cmi $bsc js_pkg

diff --git a/jscomp/runtime/js.ml b/jscomp/runtime/js.ml
@@ -228,6 +228,12 @@ module Int = Js_int
 module Bigint = Js_bigint
 (** Provide utilities for bigint *)
 
+module File = Js_file
+(** Provide utilities for File *)
+
+module Blob = Js_blob
+(** Provide utilities for Blob *)
+
 module Option = Js_option
 (** Provide utilities for option *)