Skip to content

Dom_html: fix the type of some properties and methods #1747

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 4 commits into from
Nov 27, 2024
Merged

Dom_html: fix the type of some properties and methods #1747

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
103d6f2
Dom_html: update type of mouse events and touch events
vouillon Nov 27, 2024
91acf67
Dom_html: scroll{Left,Top} properties are numbers
vouillon Nov 27, 2024
f864cf2
Dom_html: add window's scroll{X,Y} properties and scrollTop method
vouillon Nov 27, 2024
06ab46b
Changes
vouillon Nov 27, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 5 additions & 0 deletions CHANGES.md
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,3 +1,8 @@
# dev

## Features/Changes
* Lib: fix the type of some DOM properties and methods (#1747)

# 5.9.0 (2024-11-22) - Lille

## Features/Changes
Expand Down
25 changes: 13 additions & 12 deletions examples/graph_viewer/viewer_js.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -238,23 +238,23 @@ class adjustment
end

let handle_drag element f =
let mx = ref 0 in
let my = ref 0 in
let mx = ref 0. in
let my = ref 0. in
element##.onmousedown :=
Html.handler (fun ev ->
mx := ev##.clientX;
my := ev##.clientY;
mx := Js.to_float ev##.clientX;
my := Js.to_float ev##.clientY;
element##.style##.cursor := Js.string "move";
let c1 =
Html.addEventListener
Html.document
Html.Event.mousemove
(Html.handler (fun ev ->
let x = ev##.clientX and y = ev##.clientY in
let x = Js.to_float ev##.clientX and y = Js.to_float ev##.clientY in
let x' = !mx and y' = !my in
mx := x;
my := y;
f (x - x') (y - y');
f (x -. x') (y -. y');
Js._true))
Js._true
in
Expand Down Expand Up @@ -431,12 +431,13 @@ Firebug.console##log(Js.string "sleep");
sadj#set_value (float (height - pos') *. sadj#upper /. float height);
rescale 0.5 0.5)
in
handle_drag thumb (fun _dx dy -> set_slider_position (min height (max 0 (!pos + dy))));
handle_drag thumb (fun _dx dy ->
set_slider_position (min height (max 0 (!pos + int_of_float dy))));
slider##.onmousedown :=
Html.handler (fun ev ->
let ey = ev##.clientY in
let ey = Js.to_float ev##.clientY in
let _, sy = Dom_html.elementClientPosition slider in
set_slider_position (max 0 (min height (ey - sy - (size / 2))));
set_slider_position (max 0 (min height (int_of_float ey - sy - (size / 2))));
Js._false);
let adjust_slider () =
let pos' = height - truncate ((sadj#value *. float height /. sadj#upper) +. 0.5) in
Expand All @@ -454,7 +455,7 @@ Firebug.console##log(Js.string "sleep");
handle_drag canvas (fun dx dy ->
let scale = get_scale () in
let offset a d =
a#set_value (min (a#value -. (float d /. scale)) (a#upper -. a#page_size))
a#set_value (min (a#value -. (d /. scale)) (a#upper -. a#page_size))
in
offset hadj dx;
offset vadj dy;
Expand All @@ -478,8 +479,8 @@ Firebug.console##log(Js.string "sleep");
canvas
(fun ev ~dx:_ ~dy ->
let ex, ey = Dom_html.elementClientPosition canvas in
let x = float (ev##.clientX - ex) in
let y = float (ev##.clientY - ey) in
let x = Js.to_float ev##.clientX -. float ex in
let y = Js.to_float ev##.clientY -. float ey in
if dy < 0
then bump_scale x y 1.
else if dy > 0
Expand Down
37 changes: 20 additions & 17 deletions examples/hyperbolic/hypertree.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -296,10 +296,10 @@ let _debug_msg _s = ()
*)

let handle_drag element move stop click =
let fuzz = 4 in
let fuzz = 4. in
element##.onmousedown :=
Html.handler (fun ev ->
let x0 = ev##.clientX and y0 = ev##.clientY in
let x0 = Js.to_float ev##.clientX and y0 = Js.to_float ev##.clientY in
(*
debug_msg (Format.sprintf "Mouse down %d %d" x0 y0);
*)
Expand All @@ -309,11 +309,12 @@ debug_msg (Format.sprintf "Mouse down %d %d" x0 y0);
Html.document
Html.Event.mousemove
(Html.handler (fun ev ->
let x = ev##.clientX and y = ev##.clientY in
let x = Js.to_float ev##.clientX and y = Js.to_float ev##.clientY in
(*
debug_msg (Format.sprintf "Mouse move %d %d %d %d" x0 y0 x y);
*)
if (not !started) && (abs (x - x0) > fuzz || abs (y - y0) > fuzz)
if (not !started)
&& (abs_float (x -. x0) > fuzz || abs_float (y -. y0) > fuzz)
then (
started := true;
element##.style##.cursor := Js.string "move");
Expand All @@ -337,14 +338,14 @@ debug_msg (Format.sprintf "Mouse up %d %d %d %d" x0 y0 ev##clientX ev##clientY);
if !started
then (
element##.style##.cursor := Js.string "";
stop ev##.clientX ev##.clientY)
else click ev##.clientX ev##.clientY;
stop (Js.to_float ev##.clientX) (Js.to_float ev##.clientY))
else click (Js.to_float ev##.clientX) (Js.to_float ev##.clientY);
Js._true))
Js._true);
Js._true)

let handle_touch_events element move stop cancel click =
let fuzz = 4 in
let fuzz = 4. in
ignore
(Html.addEventListener
element
Expand All @@ -354,7 +355,8 @@ let handle_touch_events element move stop cancel click =
(ev##.changedTouches##item 0)
(fun touch ->
let id = touch##.identifier in
let x0 = touch##.clientX and y0 = touch##.clientY in
let x0 = Js.to_float touch##.clientX
and y0 = Js.to_float touch##.clientY in
(*
debug_msg (Format.sprintf "Touch start %d %d" x0 y0);
*)
Expand All @@ -370,12 +372,14 @@ debug_msg (Format.sprintf "Touch start %d %d" x0 y0);
(fun touch ->
if touch##.identifier = id
then (
let x = touch##.clientX and y = touch##.clientY in
let x = Js.to_float touch##.clientX
and y = Js.to_float touch##.clientY in
(*
debug_msg (Format.sprintf "Touch move %d %d %d %d" x0 y0 x y);
*)
if (not !started)
&& (abs (x - x0) > fuzz || abs (y - y0) > fuzz)
&& (abs_float (x -. x0) > fuzz
|| abs_float (y -. y0) > fuzz)
then (
started := true;
element##.style##.cursor := Js.string "move");
Expand All @@ -399,7 +403,8 @@ debug_msg (Format.sprintf "Touch start %d %d" x0 y0);
(fun touch ->
if touch##.identifier = id
then (
let x = touch##.clientX and y = touch##.clientY in
let x = Js.to_float touch##.clientX
and y = Js.to_float touch##.clientY in
(*
debug_msg (Format.sprintf "Touch end %d %d %d %d" x0 y0 x y);
*)
Expand Down Expand Up @@ -577,7 +582,7 @@ let to_screen z = ((z.x +. 1.) *. r, (z.y +. 1.) *. r)
*)
let from_screen canvas x y =
let rx, ry, dx, dy = screen_transform canvas in
let z = { x = (float x -. dx) /. rx; y = (float y -. dy) /. ry } in
let z = { x = (x -. dx) /. rx; y = (y -. dy) /. ry } in
let n = norm z in
if n <= 1. -. eps then z else sdiv z (n /. (1. -. eps))

Expand Down Expand Up @@ -1620,10 +1625,8 @@ debug_msg (Format.sprintf "Resize %d %d" w h);
let p = ref (-1) in
for i = 0 to Array.length boxes.bw - 1 do
if Array.unsafe_get boxes.bw i > 0.
&& abs_float (float x -. Array.unsafe_get boxes.bx i)
< Array.unsafe_get boxes.bw i
&& abs_float (float y -. Array.unsafe_get boxes.by i)
< Array.unsafe_get boxes.bh i
&& abs_float (x -. Array.unsafe_get boxes.bx i) < Array.unsafe_get boxes.bw i
&& abs_float (y -. Array.unsafe_get boxes.by i) < Array.unsafe_get boxes.bh i
then p := i
done;
!p
Expand All @@ -1644,7 +1647,7 @@ debug_msg (Format.sprintf "Resize %d %d" w h);
in
canvas##.onmousemove :=
Html.handler (fun ev ->
update_cursor ev##.clientX ev##.clientY;
update_cursor (Js.to_float ev##.clientX) (Js.to_float ev##.clientY);
Js._false);
handle_drag
canvas
Expand Down
20 changes: 10 additions & 10 deletions examples/planet/planet.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -683,23 +683,23 @@ let start _ =
p##.innerHTML :=
Js.string "Credit: <a href='http://visibleearth.nasa.gov/'>Visual Earth</a>, Nasa";
add doc##.body p;
let mx = ref 0 in
let my = ref 0 in
let mx = ref 0. in
let my = ref 0. in
canvas##.onmousedown :=
Dom_html.handler (fun ev ->
mx := ev##.clientX;
my := ev##.clientY;
mx := Js.to_float ev##.clientX;
my := Js.to_float ev##.clientY;
let c1 =
Html.addEventListener
Html.document
Html.Event.mousemove
(Dom_html.handler (fun ev ->
let x = ev##.clientX and y = ev##.clientY in
let dx = x - !mx and dy = y - !my in
if dy != 0
then m := matrix_mul (yz_rotation (2. *. float dy /. float width)) !m;
if dx != 0
then m := matrix_mul (xz_rotation (2. *. float dx /. float width)) !m;
let x = Js.to_float ev##.clientX and y = Js.to_float ev##.clientY in
let dx = x -. !mx and dy = y -. !my in
if dy != 0.
then m := matrix_mul (yz_rotation (2. *. dy /. float width)) !m;
if dx != 0.
then m := matrix_mul (xz_rotation (2. *. dx /. float width)) !m;
mx := x;
my := y;
Js._true))
Expand Down
59 changes: 37 additions & 22 deletions lib/js_of_ocaml/dom_html.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -297,17 +297,17 @@ and mouseEvent = object

method relatedTarget : element t opt optdef readonly_prop

method clientX : int readonly_prop
method clientX : number_t readonly_prop

method clientY : int readonly_prop
method clientY : number_t readonly_prop

method screenX : int readonly_prop
method screenX : number_t readonly_prop

method screenY : int readonly_prop
method screenY : number_t readonly_prop

method offsetX : int readonly_prop
method offsetX : number_t readonly_prop

method offsetY : int readonly_prop
method offsetY : number_t readonly_prop

method ctrlKey : bool t readonly_prop

Expand All @@ -325,9 +325,9 @@ and mouseEvent = object

method toElement : element t opt optdef readonly_prop

method pageX : int optdef readonly_prop
method pageX : number_t optdef readonly_prop

method pageY : int optdef readonly_prop
method pageY : number_t optdef readonly_prop
end

and keyboardEvent = object
Expand Down Expand Up @@ -421,17 +421,17 @@ and touch = object

method target : element t optdef readonly_prop

method screenX : int readonly_prop
method screenX : number_t readonly_prop

method screenY : int readonly_prop
method screenY : number_t readonly_prop

method clientX : int readonly_prop
method clientX : number_t readonly_prop

method clientY : int readonly_prop
method clientY : number_t readonly_prop

method pageX : int readonly_prop
method pageX : number_t readonly_prop

method pageY : int readonly_prop
method pageY : number_t readonly_prop
end

and submitEvent = object
Expand Down Expand Up @@ -727,9 +727,9 @@ and element = object

method offsetHeight : int readonly_prop

method scrollLeft : int prop
method scrollLeft : number_t prop

method scrollTop : int prop
method scrollTop : number_t prop

method scrollWidth : int prop

Expand Down Expand Up @@ -2321,9 +2321,15 @@ class type window = object

method blur : unit meth

method scroll : int -> int -> unit meth
method scrollX : number_t readonly_prop

method scrollBy : int -> int -> unit meth
method scrollY : number_t readonly_prop

method scroll : number_t -> number_t -> unit meth

method scrollTo : number_t -> number_t -> unit meth

method scrollBy : number_t -> number_t -> unit meth

method sessionStorage : storage t optdef readonly_prop

Expand Down Expand Up @@ -2888,14 +2894,22 @@ let eventRelatedTarget (e : #mouseEvent t) =
let eventAbsolutePosition' (e : #mouseEvent t) =
let body = document##.body in
let html = document##.documentElement in
( e##.clientX + body##.scrollLeft + html##.scrollLeft
, e##.clientY + body##.scrollTop + html##.scrollTop )
( Js.to_float e##.clientX
+. Js.to_float body##.scrollLeft
+. Js.to_float html##.scrollLeft
, Js.to_float e##.clientY
+. Js.to_float body##.scrollTop
+. Js.to_float html##.scrollTop )

let eventAbsolutePosition (e : #mouseEvent t) =
Optdef.case
e##.pageX
(fun () -> eventAbsolutePosition' e)
(fun x -> Optdef.case e##.pageY (fun () -> eventAbsolutePosition' e) (fun y -> x, y))
(fun x ->
Optdef.case
e##.pageY
(fun () -> eventAbsolutePosition' e)
(fun y -> Js.to_float x, Js.to_float y))

let elementClientPosition (e : #element t) =
let r = e##getBoundingClientRect in
Expand All @@ -2907,7 +2921,8 @@ let elementClientPosition (e : #element t) =
let getDocumentScroll () =
let body = document##.body in
let html = document##.documentElement in
body##.scrollLeft + html##.scrollLeft, body##.scrollTop + html##.scrollTop
( Js.to_float body##.scrollLeft +. Js.to_float html##.scrollLeft
, Js.to_float body##.scrollTop +. Js.to_float html##.scrollTop )

let buttonPressed (ev : #mouseEvent Js.t) =
Js.Optdef.case
Expand Down
Loading
Loading