rename lib

lib/gadgetobrr.ml

@@ -0,0 +1,269 @@
+open Brr
+
+type datalist =
+  { datalist_id : string
+  ; datalist_el : El.t
+  }
+
+type widget =
+  { id : string
+  ; 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 slider_class = "brridget-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
+
+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 }
+
+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 :
+       min:float
+    -> max:float
+    -> step:step_kind
+    -> value:float
+    -> id:string
+    -> label:string
+    -> datalist_id:string option
+    -> float t =
+ 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 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 container_at =
+      [ At.class' (Jstr.v slider_container_class)
+      ; At.class' (Jstr.v container_class)
+      ]
+    in
+    Slider (mk_widget ~at ~container_at ~label ~id)
+
+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 _ -> fun jv -> float_of_string (Jv.to_string jv)
+  | 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;
+      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 = (conv t) value in
+    f x
+  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 t =
+  let el = el t in
+  let body = Document.body G.document in
+  let drag_state = ref None in
+
+  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);
+    (* 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 on_mouseup _evt =
+    drag_state := None;
+    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 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;
+      El.set_inline_style El.Style.top
+        (Jstr.v (Format.sprintf "%fpx" (y +. offset_y)))
+        el;
+      ()
+  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 on_mousemove window_target in
+
+  (* ignore dragging on actual input element *)
+  let stop_on_mousedown evt = Ev.stop_propagation evt in
+  let input_el_target = El.as_target (input_el t) in
+  let _ : Ev.listener =
+    Ev.listen Ev.mousedown stop_on_mousedown input_el_target
+  in
+  ()