add text/color input
This commit is contained in:
parent
06e06a4339
commit
ff30021434
4 changed files with 210 additions and 73 deletions
|
|
@ -5,20 +5,53 @@ type datalist =
|
|||
; datalist_el : El.t
|
||||
}
|
||||
|
||||
type slider =
|
||||
type widget =
|
||||
{ id : string
|
||||
; el : El.t
|
||||
; actual_slider_el : El.t
|
||||
; input_el : El.t
|
||||
}
|
||||
|
||||
type _ t =
|
||||
| Text : widget -> string t
|
||||
| Slider : widget -> float t
|
||||
| Color : widget -> string t
|
||||
|
||||
(* Any is for continuous slider *)
|
||||
type step_kind =
|
||||
| Any
|
||||
| Step_value of float
|
||||
|
||||
let container_class = "slippery-slidy-container"
|
||||
let slider_class = "brridget-slider"
|
||||
|
||||
let slider_class = "slippery-slidy-slider"
|
||||
let slider_container_class = slider_class ^ "-container"
|
||||
|
||||
let text_class = "brridget-text"
|
||||
|
||||
let text_container_class = text_class ^ "-container"
|
||||
|
||||
let color_class = "brridget-color"
|
||||
|
||||
let color_container_class = color_class ^ "-container"
|
||||
|
||||
let container_class = "brridget-container"
|
||||
|
||||
let to_widget : type a. a t -> widget = function
|
||||
| Slider r | Text r | Color r -> r
|
||||
|
||||
let el : type a. a t -> El.t =
|
||||
fun o ->
|
||||
let r = to_widget o in
|
||||
r.el
|
||||
|
||||
let input_el : type a. a t -> El.t =
|
||||
fun o ->
|
||||
let r = to_widget o in
|
||||
r.input_el
|
||||
|
||||
let id : type a. a t -> string =
|
||||
fun o ->
|
||||
let r = to_widget o in
|
||||
r.id
|
||||
|
||||
let step_to_string step =
|
||||
match step with Any -> "any" | Step_value f -> Float.to_string f
|
||||
|
|
@ -33,6 +66,18 @@ let mk_datalist : Jstr.t list -> string -> datalist =
|
|||
in
|
||||
{ datalist_id = id; datalist_el = datalist }
|
||||
|
||||
let mk_widget ~label ~id ~at ~container_at =
|
||||
let input_el = El.input ~d:G.document ~at () in
|
||||
let label =
|
||||
El.label ~d:G.document
|
||||
~at:[ At.for' (Jstr.v id) ]
|
||||
[ El.txt' ~d:G.document label ]
|
||||
in
|
||||
let container_el =
|
||||
El.div ~d:G.document ~at:container_at [ label; input_el ]
|
||||
in
|
||||
{ id; el = container_el; input_el }
|
||||
|
||||
(* make a div of class slippery-slidy-container containing a
|
||||
slider of class slippery-slidy-slider *)
|
||||
let mk_slider :
|
||||
|
|
@ -43,7 +88,7 @@ let mk_slider :
|
|||
-> id:string
|
||||
-> label:string
|
||||
-> datalist_id:string option
|
||||
-> slider =
|
||||
-> float t =
|
||||
fun ~min ~max ~step ~value ~id ~label ~datalist_id ->
|
||||
(* some checks *)
|
||||
let b = min <= max && value <= max && value >= min in
|
||||
|
|
@ -55,33 +100,96 @@ let mk_slider :
|
|||
| 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)
|
||||
] )
|
||||
()
|
||||
let 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 ]
|
||||
let container_at =
|
||||
[ At.class' (Jstr.v slider_container_class)
|
||||
; At.class' (Jstr.v container_class)
|
||||
]
|
||||
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 }
|
||||
Slider (mk_widget ~at ~container_at ~label ~id)
|
||||
|
||||
let add_slider_input_listener slider f =
|
||||
let mk_text :
|
||||
min:int option
|
||||
-> max:int option
|
||||
-> size:int option
|
||||
-> datalist_id:string option
|
||||
-> value:string
|
||||
-> id:string
|
||||
-> label:string
|
||||
-> string t =
|
||||
fun ~min ~max ~size ~datalist_id ~value ~id ~label ->
|
||||
let min = Option.map (At.int (Jstr.v "min")) min in
|
||||
let max = Option.map (At.int (Jstr.v "max")) max in
|
||||
let size = Option.map (At.int (Jstr.v "size")) size in
|
||||
let datalist =
|
||||
Option.map (fun id -> At.v (Jstr.v "list") (Jstr.v id)) datalist_id
|
||||
in
|
||||
let opts = List.filter_map Fun.id [ min; max; size; datalist ] in
|
||||
let at =
|
||||
opts
|
||||
@ [ At.type' (Jstr.v "text")
|
||||
; At.value (Jstr.v value)
|
||||
; At.id (Jstr.v id)
|
||||
; At.class' (Jstr.v text_class)
|
||||
]
|
||||
in
|
||||
let container_at =
|
||||
[ At.class' (Jstr.v text_container_class)
|
||||
; At.class' (Jstr.v container_class)
|
||||
]
|
||||
in
|
||||
Text (mk_widget ~at ~container_at ~label ~id)
|
||||
|
||||
let color_regex =
|
||||
let regexp = Jv.get Jv.global "RegExp" in
|
||||
let re = Jv.new' regexp [| Jv.of_string "^#[0-9a-fA-F]{6}$" |] in
|
||||
re
|
||||
|
||||
let validate_color s =
|
||||
let r = Jv.call color_regex "test" [| Jv.of_string s |] in
|
||||
Jv.to_bool r
|
||||
|
||||
(* The value must be in seven-character hexadecimal notation, meaning the "#" character followed by two digits each representing red, green, and blue, like this: #rrggbb. *)
|
||||
let mk_color : value:string -> id:string -> label:string -> string t =
|
||||
fun ~value ~id ~label ->
|
||||
if not (validate_color value) then
|
||||
raise
|
||||
(Invalid_argument
|
||||
(Printf.sprintf "mk_color: `%s` is not a valid hexadecimal color" value)
|
||||
)
|
||||
else
|
||||
let at =
|
||||
[ At.type' (Jstr.v "color")
|
||||
; At.value (Jstr.v value)
|
||||
; At.id (Jstr.v id)
|
||||
; At.class' (Jstr.v color_class)
|
||||
]
|
||||
in
|
||||
let container_at =
|
||||
[ At.class' (Jstr.v color_container_class)
|
||||
; At.class' (Jstr.v container_class)
|
||||
]
|
||||
in
|
||||
Color (mk_widget ~at ~container_at ~label ~id)
|
||||
|
||||
let conv : type a. a t -> Jv.t -> a =
|
||||
fun w ->
|
||||
match w with
|
||||
| Text _ -> Jv.to_string
|
||||
| Slider _ -> Jv.to_float
|
||||
| Color _ -> (* TODO validate here and make a color type? *) Jv.to_string
|
||||
|
||||
let add_input_listener t 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;
|
||||
|
|
@ -96,47 +204,47 @@ let add_slider_input_listener slider f =
|
|||
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
|
||||
let x = (conv t) value in
|
||||
f x
|
||||
in
|
||||
let target = El.as_target slider.el in
|
||||
let target = El.as_target (el t) 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 mk_dragable t =
|
||||
let el = el t in
|
||||
let body = Document.body G.document in
|
||||
let drag_state = ref None in
|
||||
|
||||
let slider_on_mousedown evt =
|
||||
let 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 *)
|
||||
(* 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 =
|
||||
let 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 =
|
||||
let 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.position (Jstr.v "fixed") el;
|
||||
El.set_inline_style El.Style.left
|
||||
(Jstr.v (Format.sprintf "%fpx" (x +. offset_x)))
|
||||
el;
|
||||
|
|
@ -146,20 +254,16 @@ let mk_dragable slider =
|
|||
()
|
||||
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 target = El.as_target el in
|
||||
let _ : Ev.listener = Ev.listen Ev.mousedown on_mousedown target in
|
||||
let _ : Ev.listener = Ev.listen Ev.mouseup on_mouseup target in
|
||||
let window_target = Window.as_target G.window in
|
||||
let _ : Ev.listener =
|
||||
Ev.listen Ev.mousemove slider_on_mousemove window_target
|
||||
in
|
||||
let _ : Ev.listener = Ev.listen Ev.mousemove on_mousemove window_target in
|
||||
|
||||
(* ignore dragging on actual slider *)
|
||||
(* ignore dragging on actual input element *)
|
||||
let stop_on_mousedown evt = Ev.stop_propagation evt in
|
||||
let actual_slider_target = El.as_target slider.actual_slider_el in
|
||||
let input_el_target = El.as_target (input_el t) in
|
||||
let _ : Ev.listener =
|
||||
Ev.listen Ev.mousedown stop_on_mousedown actual_slider_target
|
||||
Ev.listen Ev.mousedown stop_on_mousedown input_el_target
|
||||
in
|
||||
()
|
||||
|
|
|
|||
|
|
@ -1,32 +1,58 @@
|
|||
open Brr
|
||||
|
||||
(** type for
|
||||
{{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/datalist}
|
||||
[datalist]} *)
|
||||
type datalist =
|
||||
{ datalist_id : string
|
||||
; 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 =
|
||||
{ id : string
|
||||
; el : El.t
|
||||
; actual_slider_el : El.t
|
||||
}
|
||||
(* TODO can I hide this type completly? *)
|
||||
type widget
|
||||
|
||||
(** Any is for continuous slider *)
|
||||
type _ t =
|
||||
| Text : widget -> string t
|
||||
| Slider : widget -> float t
|
||||
| Color : widget -> string t
|
||||
|
||||
(** type for the step parameter of [mk_slider] Any is for continuous slider *)
|
||||
type step_kind =
|
||||
| Any
|
||||
| Step_value of float
|
||||
|
||||
val step_to_string : step_kind -> string
|
||||
(** [id t] the id of the input element of the widget *)
|
||||
val id : 'a t -> string
|
||||
|
||||
(** [el t] the container element of the widget *)
|
||||
val el : 'a t -> El.t
|
||||
|
||||
(** [input_el t] the input element; with id [id t]; contained in the container
|
||||
element [el t] *)
|
||||
val input_el : 'a t -> El.t
|
||||
|
||||
(* TODO better type constraint on this?
|
||||
pitfall:
|
||||
making it a float list, and using Jstr.of_float
|
||||
gave me bugged float, it needs 0 at the end or smthing *)
|
||||
val mk_datalist : Jstr.t list -> string -> datalist
|
||||
|
||||
(** make a div of class "slippery-slidy-container" containing a slider of class
|
||||
"slippery-slidy-slider" wi id [id]
|
||||
(** make a div of class "brridget-container brridget-text-container" containing
|
||||
a text input of class "brridget-text" with id [id]
|
||||
|
||||
don't forget to add your slider and datalist to your document *)
|
||||
val mk_text :
|
||||
min:int option
|
||||
-> max:int option
|
||||
-> size:int option
|
||||
-> datalist_id:string option
|
||||
-> value:string
|
||||
-> id:string
|
||||
-> label:string
|
||||
-> string t
|
||||
|
||||
(** make a div of class "brridget-container brridget-slider-container"
|
||||
containing a range input of class "brridget-slider" with id [id] *)
|
||||
val mk_slider :
|
||||
min:float
|
||||
-> max:float
|
||||
|
|
@ -35,9 +61,16 @@ val mk_slider :
|
|||
-> id:string
|
||||
-> label:string
|
||||
-> datalist_id:string option
|
||||
-> slider
|
||||
-> float t
|
||||
|
||||
val add_slider_input_listener : slider -> (float -> unit) -> unit
|
||||
(** make a div of class "brridget-container brridget-color-container" containing
|
||||
a color input of class "brridget-color" with id [id] *)
|
||||
val mk_color : value:string -> id:string -> label:string -> string t
|
||||
|
||||
(** setup listener to drag and move slider with mouse *)
|
||||
val mk_dragable : slider -> unit
|
||||
(** setup listener on input *)
|
||||
val add_input_listener : 'a t -> ('a -> unit) -> unit
|
||||
|
||||
(** setup listener to drag and move slider with mouse. Works by listening to
|
||||
mousedown/mouseup/mousemove events and changing inline css style. use event
|
||||
stop_propagation + css to not highlight the page while dragging *)
|
||||
val mk_dragable : 'a t -> unit
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue