Lib: wheel event binding (#1273)

* Lib: add wheel event * Lib: rewrite addMousewheelEventListenerWithOptions * Lib: delta_mode enum instead of int * Lib: add onwheel to eventTarget * Tests: add example which uses wheel event * Misc: changes note #1272 * Lib: use mousewheelEvent instead of new wheelEvent * Lib: lwt_js for wheel * Misc: fix indentation
ocsigen · May 27, 2022 · d7117ff · d7117ff
1 parent 5a7829a
commit d7117ff
Show file tree

Hide file tree

Showing 8 changed files with 123 additions and 33 deletions.
diff --git a/CHANGES.md b/CHANGES.md
@@ -9,6 +9,7 @@
 * Lib: add missing options for Intl.NumberFormat
 * Runtime: Implement weak semantic for weak and ephemeron
 * Runtime: Implement Gc.finalise_last
+* Lib: wheel event binding
 
 ## Bug fixes
 * Compiler: fix rewriter bug in share_constant (fix #1247)

diff --git a/examples/test_wheel/dune b/examples/test_wheel/dune
@@ -0,0 +1,6 @@
+(executables
+ (names test_wheel)
+ (libraries js_of_ocaml)
+ (modes js)
+ (preprocess
+  (pps js_of_ocaml-ppx)))
diff --git a/examples/test_wheel/index.html b/examples/test_wheel/index.html
@@ -0,0 +1,12 @@
+<!DOCTYPE html>
+<html style="height: 100%;">
+
+<head>
+  <title>test_wheel</title>
+  <script defer type="text/javascript" src="test_wheel.bc.js"></script>
+</head>
+
+<body>
+</body>
+
+</html>
diff --git a/examples/test_wheel/test_wheel.ml b/examples/test_wheel/test_wheel.ml
@@ -0,0 +1,36 @@
+open Js_of_ocaml
+
+let optdef_to_string o =
+  match Js.Optdef.to_option o with
+  | Some v -> Int.to_string v
+  | None -> "undefined"
+
+let () =
+  let html =
+    Js.Opt.get
+      (Dom_html.document##querySelector (Js.string "html"))
+      (fun _ -> assert false)
+  in
+  html##.onwheel :=
+    Dom.handler (fun (event : Dom_html.mousewheelEvent Js.t) ->
+        Firebug.console##debug event;
+        let deltaX = event##.deltaX in
+        let deltaY = event##.deltaY in
+        let deltaZ = event##.deltaZ in
+        let deltaMode = event##.deltaMode in
+        let wheelDelta = event##.wheelDelta in
+        let wheelDeltaX = event##.wheelDeltaX in
+        let wheelDeltaY = event##.wheelDeltaY in
+        Printf.printf "deltaX: %f; " deltaX;
+        Printf.printf "deltaY: %f; " deltaY;
+        Printf.printf "deltaZ: %f; " deltaZ;
+        Printf.printf
+          "deltaMode: %s; "
+          (match deltaMode with
+          | Delta_pixel -> "Delta_pixel"
+          | Delta_line -> "Delta_line"
+          | Delta_page -> "Delta_page");
+        Printf.printf "wheelDelta: %d; " wheelDelta;
+        Printf.printf "wheelDeltaX: %s; " (optdef_to_string wheelDeltaX);
+        Printf.printf "wheelDeltaY: %s\n" (optdef_to_string wheelDeltaY);
+        Js._false)
diff --git a/lib/js_of_ocaml/dom_html.ml b/lib/js_of_ocaml/dom_html.ml
@@ -271,6 +271,11 @@ type mouse_button =
   | Middle_button
   | Right_button
 
+type delta_mode =
+  | Delta_pixel
+  | Delta_line
+  | Delta_page
+
 class type event =
   object
     inherit [element] Dom.event
@@ -356,14 +361,22 @@ and keyboardEvent =
 
 and mousewheelEvent =
   object
-    (* All browsers but Firefox *)
+    (* All modern browsers *)
     inherit mouseEvent
 
     method wheelDelta : int readonly_prop
 
     method wheelDeltaX : int optdef readonly_prop
 
     method wheelDeltaY : int optdef readonly_prop
+
+    method deltaX : float readonly_prop
+
+    method deltaY : float readonly_prop
+
+    method deltaZ : float readonly_prop
+
+    method deltaMode : delta_mode readonly_prop
   end
 
 and mouseScrollEvent =
@@ -495,6 +508,8 @@ and eventTarget =
 
     method onscroll : ('self t, event t) event_listener writeonly_prop
 
+    method onwheel : ('self t, mousewheelEvent t) event_listener writeonly_prop
+
     method ondragstart : ('self t, dragEvent t) event_listener writeonly_prop
 
     method ondragend : ('self t, dragEvent t) event_listener writeonly_prop
@@ -793,6 +808,8 @@ module Event = struct
 
   let mousewheel = Dom.Event.make "mousewheel"
 
+  let wheel = Dom.Event.make "wheel"
+
   let _DOMMouseScroll = Dom.Event.make "DOMMouseScroll"
 
   let touchstart = Dom.Event.make "touchstart"
@@ -2885,36 +2902,17 @@ let buttonPressed (ev : #mouseEvent Js.t) =
       | _ -> No_button)
     (fun x -> x)
 
-let hasMousewheelEvents () =
-  let d = createDiv document in
-  d##setAttribute (Js.string "onmousewheel") (Js.string "return;");
-  Js.typeof (Js.Unsafe.get d (Js.string "onmousewheel")) == Js.string "function"
-
 let addMousewheelEventListenerWithOptions e ?capture ?once ?passive h =
-  if hasMousewheelEvents ()
-  then
-    addEventListenerWithOptions
-      ?capture
-      ?once
-      ?passive
-      e
-      Event.mousewheel
-      (handler (fun (e : mousewheelEvent t) ->
-           let dx = -Optdef.get e##.wheelDeltaX (fun () -> 0) / 40 in
-           let dy = -Optdef.get e##.wheelDeltaY (fun () -> e##.wheelDelta) / 40 in
-           h (e :> mouseEvent t) ~dx ~dy))
-  else
-    addEventListenerWithOptions
-      ?capture
-      ?once
-      ?passive
-      e
-      Event._DOMMouseScroll
-      (handler (fun (e : mouseScrollEvent t) ->
-           let d = e##.detail in
-           if e##.axis == e##._HORIZONTAL_AXIS
-           then h (e :> mouseEvent t) ~dx:d ~dy:0
-           else h (e :> mouseEvent t) ~dx:0 ~dy:d))
+  addEventListenerWithOptions
+    ?capture
+    ?once
+    ?passive
+    e
+    Event.wheel
+    (handler (fun (e : mousewheelEvent t) ->
+         let dx = -Optdef.get e##.wheelDeltaX (fun () -> 0) / 40 in
+         let dy = -Optdef.get e##.wheelDeltaY (fun () -> e##.wheelDelta) / 40 in
+         h (e :> mouseEvent t) ~dx ~dy))
 
 let addMousewheelEventListener e h capt =
   addMousewheelEventListenerWithOptions ~capture:capt e h

diff --git a/lib/js_of_ocaml/dom_html.mli b/lib/js_of_ocaml/dom_html.mli
@@ -275,6 +275,11 @@ type mouse_button =
   | Middle_button
   | Right_button
 
+type delta_mode =
+  | Delta_pixel
+  | Delta_line
+  | Delta_page
+
 class type event =
   object
     inherit [element] Dom.event
@@ -365,14 +370,22 @@ and keyboardEvent =
 
 and mousewheelEvent =
   object
-    (* All browsers but Firefox *)
+    (* All modern browsers *)
     inherit mouseEvent
 
     method wheelDelta : int readonly_prop
 
     method wheelDeltaX : int optdef readonly_prop
 
     method wheelDeltaY : int optdef readonly_prop
+
+    method deltaX : float readonly_prop
+
+    method deltaY : float readonly_prop
+
+    method deltaZ : float readonly_prop
+
+    method deltaMode : delta_mode readonly_prop
   end
 
 and mouseScrollEvent =
@@ -506,6 +519,8 @@ and eventTarget =
 
     method onscroll : ('self t, event t) event_listener writeonly_prop
 
+    method onwheel : ('self t, mousewheelEvent t) event_listener writeonly_prop
+
     method ondragstart : ('self t, dragEvent t) event_listener writeonly_prop
 
     method ondragend : ('self t, dragEvent t) event_listener writeonly_prop
@@ -2353,6 +2368,8 @@ module Event : sig
 
   val _DOMMouseScroll : mouseScrollEvent t typ
 
+  val wheel : mousewheelEvent t typ
+
   val touchstart : touchEvent t typ
 
   val touchmove : touchEvent t typ
@@ -2532,7 +2549,7 @@ val addMousewheelEventListenerWithOptions :
   -> ?passive:bool t
   -> (mouseEvent t -> dx:int -> dy:int -> bool t)
   -> event_listener_id
-(** Add a mousewheel event listener with option-object variant of the
+(** Add a wheel event listener with option-object variant of the
       [addEventListener] DOM method.  The callback is provided the
       event and the numbers of ticks the mouse wheel moved.  Positive
       means down / right. *)
@@ -2542,7 +2559,7 @@ val addMousewheelEventListener :
   -> (mouseEvent t -> dx:int -> dy:int -> bool t)
   -> bool t
   -> event_listener_id
-(** Add a mousewheel event listener with the useCapture boolean variant
+(** Add a wheel event listener with the useCapture boolean variant
       of the [addEventListener] DOM method.  The callback is provided the
       event and the numbers of ticks the mouse wheel moved.  Positive
       means down / right. *)

diff --git a/lib/lwt/lwt_js_events.ml b/lib/lwt/lwt_js_events.ml
@@ -342,6 +342,9 @@ let mousewheel ?use_capture ?passive target =
    make_event Dom_html.Event._DOMMouseScroll ?use_capture ?passive target
 *)
 
+let wheel ?use_capture ?passive target =
+  make_event Dom_html.Event.wheel ?use_capture ?passive target
+
 let touchstart ?use_capture ?passive target =
   make_event Dom_html.Event.touchstart ?use_capture ?passive target
 
@@ -456,6 +459,9 @@ let drops ?cancel_handler ?use_capture ?passive t =
 let mousewheels ?cancel_handler ?use_capture ?passive t =
   seq_loop mousewheel ?cancel_handler ?use_capture ?passive t
 
+let wheels ?cancel_handler ?use_capture ?passive t =
+  seq_loop wheel ?cancel_handler ?use_capture ?passive t
+
 let touchstarts ?cancel_handler ?use_capture ?passive t =
   seq_loop touchstart ?cancel_handler ?use_capture ?passive t
 

diff --git a/lib/lwt/lwt_js_events.mli b/lib/lwt/lwt_js_events.mli
@@ -362,6 +362,12 @@ val mousewheel :
     Positive means down or right.
     This interface is compatible with all (recent) browsers. *)
 
+val wheel :
+     ?use_capture:bool
+  -> ?passive:bool
+  -> #Dom_html.eventTarget Js.t
+  -> Dom_html.mousewheelEvent Js.t Lwt.t
+
 val touchstart :
      ?use_capture:bool
   -> ?passive:bool
@@ -773,6 +779,14 @@ val mousewheels :
   -> (Dom_html.mouseEvent Js.t * (int * int) -> unit Lwt.t -> unit Lwt.t)
   -> unit Lwt.t
 
+val wheels :
+     ?cancel_handler:bool
+  -> ?use_capture:bool
+  -> ?passive:bool
+  -> #Dom_html.eventTarget Js.t
+  -> (Dom_html.mousewheelEvent Js.t -> unit Lwt.t -> unit Lwt.t)
+  -> unit Lwt.t
+
 val touchstarts :
      ?cancel_handler:bool
   -> ?use_capture:bool