add mk_dragable

examples/slider.ml

@@ -22,11 +22,12 @@ let () =
       ~id:"my-slider" ~label:"Important slider, slide carefully"
       ~datalist_id:(Some datalist.datalist_id)
   in
-  append_el_to_main slider.slider_el;
+  append_el_to_main slider.el;
   (* don't forget to add datalist to document too! *)
   append_el_to_main datalist.datalist_el;
 
   (* add listener on slider change *)
   Slippery_slidy.add_slider_input_listener slider (fun x ->
       Printf.printf "slider value: %f !!@." x );
+  Slippery_slidy.mk_dragable slider;
   ()

examples/style.css

@@ -0,0 +1,12 @@
+.slippery-slidy-container {
+  display: flex;
+  flex-direction: column;
+  position: fixed;
+  top: 5vh;
+  left: 5vw;
+  background-color: black;
+  color: white;
+  opacity: 0.7;
+  padding-block: 2vh;
+  padding-inline: 1vw;
+}

lib/slippery_slidy.ml

@@ -6,8 +6,9 @@ type datalist =
   }
 
 type slider =
-  { slider_id : string
+  { id : string
-  ; slider_el : El.t
+  ; 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
+  ()

lib/slippery_slidy.mli

@@ -5,9 +5,13 @@ type datalist =
   ; datalist_el : El.t
   }
 
+(** - [id] is the id of the actual_slider_el element
+    - [el] is the slider container element
+    - [actual_slider_el] is the input slider *)
 type slider =
-  { slider_id : string
+  { id : string
-  ; slider_el : El.t
+  ; el : El.t
+  ; actual_slider_el : El.t
   }
 
 (** Any is for continuous slider *)
@@ -34,3 +38,6 @@ val mk_slider :
   -> slider
 
 val add_slider_input_listener : slider -> (float -> unit) -> unit
+
+(** setup listener to drag and move slider with mouse *)
+val mk_dragable : slider -> unit