gadgetobrr/lib/slippery_slidy.ml

open Brr

type datalist =
  { datalist_id : string
  ; datalist_el : El.t
  }

type slider =
  { id : string
  ; el : El.t
  ; actual_slider_el : El.t
  }

(* Any is for continuous slider *)
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

let mk_datalist : Jstr.t list -> string -> datalist =
 fun l id ->
  let option_el_l =
    List.map (fun s -> El.option ~d:G.document ~at:[ At.value s ] []) l
  in
  let datalist =
    El.datalist ~d:G.document ~at:[ At.id (Jstr.v id) ] option_el_l
  in
  { datalist_id = id; datalist_el = datalist }

(* make a div of class slippery-slidy-container containing a
   slider of class slippery-slidy-slider *)
let mk_slider :
       min:float
    -> max:float
    -> step:step_kind
    -> value:float
    -> id:string
    -> label:string
    -> datalist_id:string option
    -> slider =
 fun ~min ~max ~step ~value ~id ~label ~datalist_id ->
  (* some checks *)
  let b = min <= max && value <= max && value >= min in
  if not b then
    raise (Invalid_argument "mk_slider: parameters did not pass validation")
  else
    let datalist =
      match datalist_id with
      | None -> []
      | Some datalist_id -> [ At.v (Jstr.v "list") (Jstr.v datalist_id) ]
    in
    let input_el =
      El.input ~d:G.document
        ~at:
          ( datalist
          @ [ At.type' (Jstr.v "range")
            ; At.float (Jstr.v "min") min
            ; At.float (Jstr.v "max") max
            ; 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 slider_class)
            ] )
        ()
    in
    let label =
      El.label ~d:G.document
        ~at:[ At.for' (Jstr.v id) ]
        [ El.txt' ~d:G.document label ]
    in
    let slider_container_el =
      El.div ~d:G.document
        ~at:[ At.class' (Jstr.v container_class) ]
        [ label; input_el ]
    in
    { 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:
     "For <textarea> and <input> elements that accept
      text input (type=text, type=tel, etc.), the interface is InputEvent;
      for others, the interface is Event."

     passing the El.t to the handler to avoid using Obj.magic to get "evt.target"
     and directly doing "el.value" in the handler does not work for some reason
     (we get a value="") *)
  let handler evt =
    (* here evt is a "Event" not a "EventInput"
       no need to take Ev.as_type *)
    let evt : Jv.t = Obj.magic evt in
    let target : Jv.t = Jv.get evt "target" in
    let value : Jv.t = Jv.get target "value" in
    let x = float_of_string (Jv.to_string value) in
    f x
  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
  ()