165 lines
5 KiB
OCaml
165 lines
5 KiB
OCaml
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
|
|
()
|