diff --git a/lib/js_of_ocaml/typed_array.ml b/lib/js_of_ocaml/typed_array.ml index f0bd32f2a..e06f3b50b 100644 --- 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,8 +42,8 @@ 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 @@ -49,47 +51,61 @@ class type ['a, 'b] typedArray = object 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 index 21c80fb6f..33d5eca01 100644 --- 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,8 +44,8 @@ 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 @@ -51,41 +53,58 @@ class type ['a, 'b] typedArray = object 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 index b81df76f1..299362873 100644 --- 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";