Lib: update typing of typed arrays

ocaml-wasm · Sep 2, 2024 · a2c5109 · a2c5109
1 parent 4d2b8b3
commit a2c5109
Show file tree

Hide file tree

Showing 3 changed files with 132 additions and 76 deletions.
diff --git a/lib/js_of_ocaml/typed_array.ml b/lib/js_of_ocaml/typed_array.ml
@@ -20,7 +20,9 @@
 open! Import
 open Js
 
-type uint32 = float
+type int32 = number_t
+
+type uint32 = number_t
 
 class type arrayBuffer = object
   method byteLength : int readonly_prop
@@ -40,56 +42,70 @@ class type arrayBufferView = object
   method byteLength : int readonly_prop
 end
 
-class type ['a, 'b] typedArray = object
-  inherit arrayBufferView
+class type ['a, 'b, 'c] typedArray = object
+    inherit arrayBufferView
 
   method _BYTES_PER_ELEMENT : int readonly_prop
 
   method length : int readonly_prop
 
   method set_fromArray : 'a js_array t -> int -> unit meth
 
-  method set_fromTypedArray : ('a, 'b) typedArray t -> int -> unit meth
+  method set_fromTypedArray : ('a, 'b, 'c) typedArray t -> int -> unit meth
 
-  method subarray : int -> int -> ('a, 'b) typedArray t meth
+  method subarray : int -> int -> ('a, 'b, 'c) typedArray t meth
 
-  method subarray_toEnd : int -> ('a, 'b) typedArray t meth
+  method subarray_toEnd : int -> ('a, 'b, 'c) typedArray t meth
 
-  method slice : int -> int -> ('a, 'b) typedArray t meth
+  method slice : int -> int -> ('a, 'b, 'c) typedArray t meth
 
-  method slice_toEnd : int -> ('a, 'b) typedArray t meth
+  method slice_toEnd : int -> ('a, 'b, 'c) typedArray t meth
 
   (* This fake method is needed for typing purposes.
      Without it, ['b] would not be constrained. *)
-  method _content_type_ : 'b optdef readonly_prop
+  method _content_type_ : ('b * 'c) optdef readonly_prop
 end
 
-type int8Array = (int, Bigarray.int8_signed_elt) typedArray
+type int8Array = (int, int, Bigarray.int8_signed_elt) typedArray
 
-type uint8Array = (int, Bigarray.int8_unsigned_elt) typedArray
+type uint8Array = (int, int, Bigarray.int8_unsigned_elt) typedArray
 
-type int16Array = (int, Bigarray.int16_signed_elt) typedArray
+type int16Array = (int, int, Bigarray.int16_signed_elt) typedArray
 
-type uint16Array = (int, Bigarray.int16_unsigned_elt) typedArray
+type uint16Array = (int, int, Bigarray.int16_unsigned_elt) typedArray
 
-type int32Array = (int32, Bigarray.int32_elt) typedArray
+type int32Array = (int32, Int32.t, Bigarray.int32_elt) typedArray
 
-type uint32Array = (int32, Bigarray.int32_elt) typedArray
+type uint32Array = (uint32, Int32.t, Bigarray.int32_elt) typedArray
 
-type float32Array = (float, Bigarray.float32_elt) typedArray
+type float32Array = (number_t, float, Bigarray.float32_elt) typedArray
 
-type float64Array = (float, Bigarray.float64_elt) typedArray
+type float64Array = (number_t, float, Bigarray.float64_elt) typedArray
 
-external kind : ('a, 'b) typedArray t -> ('a, 'b) Bigarray.kind
+type ('bigarray, 'typed_array, 'elt) type' =
+  | Char : (int, char, Bigarray.int8_unsigned_elt) type'
+  | Int8_signed : (int, int, Bigarray.int8_signed_elt) type'
+  | Int8_unsigned : (int, int, Bigarray.int8_unsigned_elt) type'
+  | Int16_signed : (int, int, Bigarray.int16_signed_elt) type'
+  | Int16_unsigned : (int, int, Bigarray.int16_unsigned_elt) type'
+  | Int32_signed : (int32, Int32.t, Bigarray.int32_elt) type'
+  | Int32_unsigned : (uint32, Int32.t, Bigarray.int32_elt) type'
+  | Float32 : (number_t, float, Bigarray.float32_elt) type'
+  | Float64 : (number_t, float, Bigarray.float64_elt) type'
+
+external kind :
+  ('typed_array, 'bigarray, 'elt) typedArray t -> ('bigarray, 'elt) Bigarray.kind
   = "caml_ba_kind_of_typed_array"
 
-external from_genarray :
-  ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t -> ('a, 'b) typedArray t
-  = "caml_ba_to_typed_array"
+external from_genarray_impl :
+     ('bigarray, 'elt, Bigarray.c_layout) Bigarray.Genarray.t
+  -> ('typed_array, 'bigarray, 'elt) typedArray t = "caml_ba_to_typed_array"
 
 external to_genarray :
-  ('a, 'b) typedArray t -> ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t
-  = "caml_ba_from_typed_array"
+     ('typed_array, 'bigarray, 'elt) typedArray t
+  -> ('bigarray, 'elt, Bigarray.c_layout) Bigarray.Genarray.t = "caml_ba_from_typed_array"
+
+let from_genarray _ a = from_genarray_impl a
 
 let int8Array = Js.Unsafe.global##._Int8Array
 
@@ -171,12 +187,12 @@ let float64Array_fromBuffer = float64Array
 
 let float64Array_inBuffer = float64Array
 
-let set : ('a, 'b) typedArray t -> int -> 'a -> unit =
+let set : ('a, _, _) typedArray t -> int -> 'a -> unit =
  fun a i v -> array_set (Unsafe.coerce a) i v
 
-let get : ('a, 'b) typedArray t -> int -> 'a optdef = fun a i -> Js.Unsafe.get a i
+let get : ('a, _, _) typedArray t -> int -> 'a optdef = fun a i -> Js.Unsafe.get a i
 
-let unsafe_get : ('a, 'b) typedArray t -> int -> 'a = fun a i -> Js.Unsafe.get a i
+let unsafe_get : ('a, _, _) typedArray t -> int -> 'a = fun a i -> Js.Unsafe.get a i
 
 class type dataView = object
   inherit arrayBufferView
@@ -193,9 +209,9 @@ class type dataView = object
 
   method getUint16_ : int -> bool t -> int meth
 
-  method getInt32 : int -> int meth
+  method getInt32 : int -> int32 meth
 
-  method getInt32_ : int -> bool t -> int meth
+  method getInt32_ : int -> bool t -> int32 meth
 
   method getUint32 : int -> uint32 meth
 
@@ -221,9 +237,9 @@ class type dataView = object
 
   method setUint16_ : int -> int -> bool t -> unit meth
 
-  method setInt32 : int -> int -> unit meth
+  method setInt32 : int -> int32 -> unit meth
 
-  method setInt32_ : int -> int -> bool t -> unit meth
+  method setInt32_ : int -> int32 -> bool t -> unit meth
 
   method setUint32 : int -> uint32 -> unit meth
 

diff --git a/lib/js_of_ocaml/typed_array.mli b/lib/js_of_ocaml/typed_array.mli
@@ -22,7 +22,9 @@
 
 open Js
 
-type uint32 = float
+type int32 = number_t
+
+type uint32 = number_t
 
 class type arrayBuffer = object
   method byteLength : int readonly_prop
@@ -42,50 +44,67 @@ class type arrayBufferView = object
   method byteLength : int readonly_prop
 end
 
-class type ['a, 'b] typedArray = object
-  inherit arrayBufferView
+class type ['a, 'b, 'c] typedArray = object
+    inherit arrayBufferView
 
   method _BYTES_PER_ELEMENT : int readonly_prop
 
   method length : int readonly_prop
 
   method set_fromArray : 'a js_array t -> int -> unit meth
 
-  method set_fromTypedArray : ('a, 'b) typedArray t -> int -> unit meth
+  method set_fromTypedArray : ('a, 'b, 'c) typedArray t -> int -> unit meth
 
-  method subarray : int -> int -> ('a, 'b) typedArray t meth
+  method subarray : int -> int -> ('a, 'b, 'c) typedArray t meth
 
-  method subarray_toEnd : int -> ('a, 'b) typedArray t meth
+  method subarray_toEnd : int -> ('a, 'b, 'c) typedArray t meth
 
-  method slice : int -> int -> ('a, 'b) typedArray t meth
+  method slice : int -> int -> ('a, 'b, 'c) typedArray t meth
 
-  method slice_toEnd : int -> ('a, 'b) typedArray t meth
+  method slice_toEnd : int -> ('a, 'b, 'c) typedArray t meth
 
-  method _content_type_ : 'b optdef readonly_prop
+  (* This fake method is needed for typing purposes. Without it, ['b] would not
+     be constrained. *)
+  method _content_type_ : ('b * 'c) optdef readonly_prop
 end
 
-type int8Array = (int, Bigarray.int8_signed_elt) typedArray
+type int8Array = (int, int, Bigarray.int8_signed_elt) typedArray
+
+type uint8Array = (int, int, Bigarray.int8_unsigned_elt) typedArray
 
-type uint8Array = (int, Bigarray.int8_unsigned_elt) typedArray
+type int16Array = (int, int, Bigarray.int16_signed_elt) typedArray
 
-type int16Array = (int, Bigarray.int16_signed_elt) typedArray
+type uint16Array = (int, int, Bigarray.int16_unsigned_elt) typedArray
 
-type uint16Array = (int, Bigarray.int16_unsigned_elt) typedArray
+type int32Array = (int32, Int32.t, Bigarray.int32_elt) typedArray
 
-type int32Array = (int32, Bigarray.int32_elt) typedArray
+type uint32Array = (uint32, Int32.t, Bigarray.int32_elt) typedArray
 
-type uint32Array = (int32, Bigarray.int32_elt) typedArray
+type float32Array = (number_t, float, Bigarray.float32_elt) typedArray
 
-type float32Array = (float, Bigarray.float32_elt) typedArray
+type float64Array = (number_t, float, Bigarray.float64_elt) typedArray
 
-type float64Array = (float, Bigarray.float64_elt) typedArray
+type ('bigarray, 'typed_array, 'elt) type' =
+  | Char : (int, char, Bigarray.int8_unsigned_elt) type'
+  | Int8_signed : (int, int, Bigarray.int8_signed_elt) type'
+  | Int8_unsigned : (int, int, Bigarray.int8_unsigned_elt) type'
+  | Int16_signed : (int, int, Bigarray.int16_signed_elt) type'
+  | Int16_unsigned : (int, int, Bigarray.int16_unsigned_elt) type'
+  | Int32_signed : (int32, Int32.t, Bigarray.int32_elt) type'
+  | Int32_unsigned : (uint32, Int32.t, Bigarray.int32_elt) type'
+  | Float32 : (number_t, float, Bigarray.float32_elt) type'
+  | Float64 : (number_t, float, Bigarray.float64_elt) type'
 
-val kind : ('a, 'b) typedArray t -> ('a, 'b) Bigarray.kind
+val kind : ('typed_array, 'bigarray, 'elt) typedArray t -> ('bigarray, 'elt) Bigarray.kind
 
 val from_genarray :
-  ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t -> ('a, 'b) typedArray t
+     ('typed_array, 'bigarray, 'elt) type'
+  -> ('bigarray, 'elt, Bigarray.c_layout) Bigarray.Genarray.t
+  -> ('typed_array, 'bigarray, 'elt) typedArray t
 
-val to_genarray : ('a, 'b) typedArray t -> ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t
+val to_genarray :
+     ('typed_array, 'bigarray, 'elt) typedArray t
+  -> ('bigarray, 'elt, Bigarray.c_layout) Bigarray.Genarray.t
 
 val int8Array : (int -> int8Array t) constr
 
@@ -167,11 +186,11 @@ val float64Array_fromBuffer : (arrayBuffer t -> float64Array t) constr
 
 val float64Array_inBuffer : (arrayBuffer t -> int -> int -> float64Array t) constr
 
-val set : ('a, 'b) typedArray t -> int -> 'a -> unit
+val set : ('a, _, _) typedArray t -> int -> 'a -> unit
 
-val get : ('a, 'b) typedArray t -> int -> 'a optdef
+val get : ('a, _, _) typedArray t -> int -> 'a optdef
 
-val unsafe_get : ('a, 'b) typedArray t -> int -> 'a
+val unsafe_get : ('a, _, _) typedArray t -> int -> 'a
 
 class type dataView = object
   inherit arrayBufferView
@@ -188,9 +207,9 @@ class type dataView = object
 
   method getUint16_ : int -> bool t -> int meth
 
-  method getInt32 : int -> int meth
+  method getInt32 : int -> int32 meth
 
-  method getInt32_ : int -> bool t -> int meth
+  method getInt32_ : int -> bool t -> int32 meth
 
   method getUint32 : int -> uint32 meth
 
@@ -216,9 +235,9 @@ class type dataView = object
 
   method setUint16_ : int -> int -> bool t -> unit meth
 
-  method setInt32 : int -> int -> unit meth
+  method setInt32 : int -> int32 -> unit meth
 
-  method setInt32_ : int -> int -> bool t -> unit meth
+  method setInt32_ : int -> int32 -> bool t -> unit meth
 
   method setUint32 : int -> uint32 -> unit meth
 

diff --git a/lib/tests/test_typed_array.ml b/lib/tests/test_typed_array.ml
@@ -18,24 +18,24 @@
 
 open Js_of_ocaml
 open Typed_array
-open Bigarray
+open! Bigarray
 
 type ('a, 'b) ba = ('a, 'b, c_layout) Genarray.t
 
-type ('a, 'b) ta = ('a, 'b) typedArray
+type ('a, 'b, 'c) ta = ('a, 'b, 'c) typedArray
 
 module Setup = struct
-  type (_, _) t =
-    | Int8 : (int, Bigarray.int8_signed_elt) t
-    | Uint8 : (int, Bigarray.int8_unsigned_elt) t
-    | Int16 : (int, Bigarray.int16_signed_elt) t
-    | Uint16 : (int, Bigarray.int16_unsigned_elt) t
-    | Int32 : (int32, Bigarray.int32_elt) t
-    | Float32 : (float, Bigarray.float32_elt) t
-    | Float64 : (float, Bigarray.float64_elt) t
+  type (_, _, _) t =
+    | Int8 : (int, int, Bigarray.int8_signed_elt) t
+    | Uint8 : (int, int, Bigarray.int8_unsigned_elt) t
+    | Int16 : (int, int, Bigarray.int16_signed_elt) t
+    | Uint16 : (int, int, Bigarray.int16_unsigned_elt) t
+    | Int32 : (Js.number_t, Int32.t, Bigarray.int32_elt) t
+    | Float32 : (Js.number_t, float, Bigarray.float32_elt) t
+    | Float64 : (Js.number_t, float, Bigarray.float64_elt) t
 end
 
-let kind_of_setup : type a b. (a, b) Setup.t -> (a, b) kind = function
+let kind_of_setup : type a b c. (a, b, c) Setup.t -> (b, c) kind = function
   | Setup.Int8 -> Int8_signed
   | Setup.Uint8 -> Int8_unsigned
   | Setup.Int16 -> Int16_signed
@@ -44,7 +44,25 @@ let kind_of_setup : type a b. (a, b) Setup.t -> (a, b) kind = function
   | Setup.Float32 -> Float32
   | Setup.Float64 -> Float64
 
-let ta_type_is_correct : type a b. (a, b) Setup.t -> (a, b) ta Js.t -> bool =
+let convert : type a b c. (a, b, c) Setup.t -> a -> b = function
+  | Setup.Int8 -> Fun.id
+  | Setup.Uint8 -> Fun.id
+  | Setup.Int16 -> Fun.id
+  | Setup.Uint16 -> Fun.id
+  | Setup.Int32 -> fun f -> Int32.of_float (Js.to_float f)
+  | Setup.Float32 -> Js.to_float
+  | Setup.Float64 -> Js.to_float
+
+let type_of_setup : type a b c. (a, b, c) Setup.t -> (a, b, c) type' = function
+  | Setup.Int8 -> Int8_signed
+  | Setup.Uint8 -> Int8_unsigned
+  | Setup.Int16 -> Int16_signed
+  | Setup.Uint16 -> Int16_unsigned
+  | Setup.Int32 -> Int32_signed
+  | Setup.Float32 -> Float32
+  | Setup.Float64 -> Float64
+
+let ta_type_is_correct : type a b c. (a, b, c) Setup.t -> (a, b, c) ta Js.t -> bool =
  fun setup a ->
   let get_prop prop obj = Js.Unsafe.get obj (Js.string prop) in
   let name = a |> get_prop "constructor" |> get_prop "name" |> Js.to_string in
@@ -58,7 +76,7 @@ let ta_type_is_correct : type a b. (a, b) Setup.t -> (a, b) ta Js.t -> bool =
   | Setup.Int32, "Int32Array" -> true
   | _, _ -> false
 
-let kind_field_is_correct : type a b. (a, b) Setup.t -> (a, b) ba -> bool =
+let kind_field_is_correct : type a b c. (a, b, c) Setup.t -> (b, c) ba -> bool =
  fun setup a ->
   (* To trigger a `false`, modify the `kind` integer hard coded in the
    * `caml_ba_kind_of_typed_array` stub
@@ -73,7 +91,7 @@ let kind_field_is_correct : type a b. (a, b) Setup.t -> (a, b) ba -> bool =
   | Int32, Int32 -> true
   | _, _ -> false
 
-let ba_of_array : type a b. (a, b) Setup.t -> a array -> (a, b) ba =
+let ba_of_array : type a b c. (a, b, c) Setup.t -> b array -> (b, c) ba =
  fun setup a -> Array1.of_array (kind_of_setup setup) c_layout a |> genarray_of_array1
 
 let array_of_ba : type a b. (a, b) ba -> a array =
@@ -85,16 +103,19 @@ let array_of_ba : type a b. (a, b) ba -> a array =
   in
   aux 0 |> Array.of_list
 
-let array_of_ta : type a b. (a, b) Setup.t -> (a, b) ta Js.t -> a array =
- fun _ a ->
+let array_of_ta : type a b c. (a, b, c) Setup.t -> (a, b, c) ta Js.t -> b array =
+ fun setup a ->
   let len = a##.length in
-  let rec aux i = if i == len then [] else unsafe_get a i :: aux (i + 1) in
+  let rec aux i =
+    if i == len then [] else convert setup (unsafe_get a i) :: aux (i + 1)
+  in
   aux 0 |> Array.of_list
 
-let test setup a0 =
+let test : type a b c. (a, b, c) Setup.t -> b array -> unit =
+ fun setup a0 ->
   let a1 = ba_of_array setup a0 in
 
-  let a2 = from_genarray a1 in
+  let a2 = from_genarray (type_of_setup setup) a1 in
   if not (array_of_ta setup a2 = a0) then print_endline "`a2` doesnt match `a0`";
   if not (ta_type_is_correct setup a2) then print_endline "corrupted typedArray type";