add mk_dragable

lib/slippery_slidy.ml

@@ -6,8 +6,9 @@ type datalist =
   }
 
 type slider =
-  { slider_id : string
-  ; slider_el : El.t
+  { id : string
+  ; el : El.t
+  ; actual_slider_el : El.t
   }
 
 (* Any is for continuous slider *)
@@ -15,6 +16,10 @@ type step_kind =
   | Any
   | Step_value of float
 
+let container_class = "slippery-slidy-container"
+
+let slider_class = "slippery-slidy-slider"
+
 let step_to_string step =
   match step with Any -> "any" | Step_value f -> Float.to_string f
 
@@ -60,7 +65,7 @@ let mk_slider :
             ; At.v (Jstr.v "step") (Jstr.v (step_to_string step))
             ; At.value (Jstr.of_float value)
             ; At.id (Jstr.v id)
-            ; At.class' (Jstr.v "slippery-slidy-slider")
+            ; At.class' (Jstr.v slider_class)
             ] )
         ()
     in
@@ -71,10 +76,10 @@ let mk_slider :
     in
     let slider_container_el =
       El.div ~d:G.document
-        ~at:[ At.class' (Jstr.v "slippery-slidy-container") ]
+        ~at:[ At.class' (Jstr.v container_class) ]
         [ label; input_el ]
     in
-    { slider_id = id; slider_el = slider_container_el }
+    { id; el = slider_container_el; actual_slider_el = input_el }
 
 let add_slider_input_listener slider f =
   (* we do not use Ev.input because it makes a Ev.Input.t but:
@@ -94,7 +99,67 @@ let add_slider_input_listener slider f =
     let x = float_of_string (Jv.to_string value) in
     f x
   in
-  let target = El.as_target slider.slider_el in
+  let target = El.as_target slider.el in
   let input_ev = Ev.Type.create (Jstr.v "input") in
   let _ : Ev.listener = Ev.listen input_ev handler target in
   ()
+
+let mk_dragable slider =
+  let el = slider.el in
+  let body = Document.body G.document in
+  let drag_state = ref None in
+
+  let slider_on_mousedown evt =
+    let evt = Ev.as_type evt in
+    let offset_x = El.bound_x el -. Ev.Mouse.client_x evt in
+    let offset_y = El.bound_y el -. Ev.Mouse.client_y evt in
+    drag_state := Some (offset_x, offset_y);
+    (* add css so nothing get highlighted *)
+    El.set_inline_style (Jstr.v "user-select") (Jstr.v "none") body;
+    El.set_inline_style (Jstr.v "pointer-events") (Jstr.v "none") body;
+    El.set_inline_style (Jstr.v "pointer-events") (Jstr.v "auto") el;
+    ()
+  in
+
+  let slider_on_mouseup _evt =
+    drag_state := None;
+    (* rm css *)
+    El.set_inline_style (Jstr.v "user-select") (Jstr.v "") body;
+    El.set_inline_style (Jstr.v "pointer-events") (Jstr.v "") body;
+    El.set_inline_style (Jstr.v "pointer-events") (Jstr.v "") el;
+    ()
+  in
+
+  let slider_on_mousemove evt =
+    match !drag_state with
+    | None -> ()
+    | Some (offset_x, offset_y) ->
+      let evt = Ev.as_type evt in
+      let x = Ev.Mouse.client_x evt in
+      let y = Ev.Mouse.client_y evt in
+      El.set_inline_style El.Style.left
+        (Jstr.v (Format.sprintf "%fpx" (x +. offset_x)))
+        el;
+      El.set_inline_style El.Style.top
+        (Jstr.v (Format.sprintf "%fpx" (y +. offset_y)))
+        el;
+      ()
+  in
+
+  let slider_target = El.as_target el in
+  let _ : Ev.listener =
+    Ev.listen Ev.mousedown slider_on_mousedown slider_target
+  in
+  let _ : Ev.listener = Ev.listen Ev.mouseup slider_on_mouseup slider_target in
+  let window_target = Window.as_target G.window in
+  let _ : Ev.listener =
+    Ev.listen Ev.mousemove slider_on_mousemove window_target
+  in
+
+  (* ignore dragging on actual slider *)
+  let stop_on_mousedown evt = Ev.stop_propagation evt in
+  let actual_slider_target = El.as_target slider.actual_slider_el in
+  let _ : Ev.listener =
+    Ev.listen Ev.mousedown stop_on_mousedown actual_slider_target
+  in
+  ()