From ff3002143430bd1a124b23b6b2cc12369f5c6a76 Mon Sep 17 00:00:00 2001
From: Swrup <swrup@protonmail.com>
Date: Tue, 16 Apr 2024 02:15:55 +0200
Subject: [PATCH] add text/color input

---
 examples/slider.ml     |  14 +--
 examples/style.css     |   2 +-
 lib/slippery_slidy.ml  | 202 +++++++++++++++++++++++++++++++----------
 lib/slippery_slidy.mli |  65 +++++++++----
 4 files changed, 210 insertions(+), 73 deletions(-)

diff --git a/examples/slider.ml b/examples/slider.ml
index ea5b849..6440ce9 100644
--- a/examples/slider.ml
+++ b/examples/slider.ml
@@ -1,6 +1,7 @@
 (* This add a slidder to into <main>
    moving the slider print its value to the console *)
 open Brr
+open Slippery_slidy
 
 let append_el_to_main el =
   let main =
@@ -13,21 +14,20 @@ let append_el_to_main el =
 
 let () =
   let datalist =
-    Slippery_slidy.mk_datalist
+    mk_datalist
       (List.map Jstr.of_float [ 2.; 3.; 5.; 8.; 13. ])
       "my-slider-datalist"
   in
   let slider =
-    Slippery_slidy.mk_slider ~min:0. ~max:100. ~step:Any ~value:50.
-      ~id:"my-slider" ~label:"Important slider, slide carefully"
+    mk_slider ~min:0. ~max:100. ~step:Any ~value:50. ~id:"my-slider"
+      ~label:"Important slider, slide carefully"
       ~datalist_id:(Some datalist.datalist_id)
   in
-  append_el_to_main slider.el;
+  append_el_to_main (el slider);
   (* 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;
+  add_input_listener slider (fun x -> Printf.printf "slider value: %f !!@." x);
+  mk_dragable slider;
   ()
diff --git a/examples/style.css b/examples/style.css
index a1dd884..7f81773 100644
--- a/examples/style.css
+++ b/examples/style.css
@@ -1,4 +1,4 @@
-.slippery-slidy-container {
+.brridget-container {
   display: flex;
   flex-direction: column;
   position: fixed;
diff --git a/lib/slippery_slidy.ml b/lib/slippery_slidy.ml
index 3a42549..dcc2eb4 100644
--- a/lib/slippery_slidy.ml
+++ b/lib/slippery_slidy.ml
@@ -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
   ()
diff --git a/lib/slippery_slidy.mli b/lib/slippery_slidy.mli
index 760707a..5fd2e84 100644
--- a/lib/slippery_slidy.mli
+++ b/lib/slippery_slidy.mli
@@ -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