gadgetobrr

+ moving the slider print its value to the console *) +open Brr +open Gadgetobrr + +let append_el_to_body el = + let body = + match El.find_first_by_selector (Jstr.v "body") with + | Some body -> body + | None -> failwith "append_el_to_body: body element not found" + in + El.append_children body [ el ]; + () + +let () = + let datalist = + mk_datalist (List.map Jstr.v [ "cc"; "sava"; "bb" ]) "my-text-datalist" + in + let text = + mk_text ~min:(Some 0) ~max:(Some 100) ~size:(Some 4) ~value:"?" + ~id:"my-text" ~label:"Important text, input carefully" + ~datalist_id:(Some datalist.datalist_id) + in + add_input_listener text (fun s -> Printf.printf "text value: %s\n" s); + mk_dragable text; + append_el_to_body (el text); + append_el_to_body datalist.datalist_el; + + let datalist = + mk_datalist + (List.map Jstr.of_float [ 2.; 3.; 5.; 8.; 13. ]) + "my-slider-datalist" + in + let slider = + 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 + add_input_listener slider (fun x -> Printf.printf "slider value: %f\n" x); + mk_dragable slider; + append_el_to_body (el slider); + append_el_to_body datalist.datalist_el; + + let color = + mk_color ~value:"#00ff00" ~id:"my-color" + ~label:"Important color, pick carefully" + in + add_input_listener color (fun s -> Printf.printf "color value: %s\n" s); + mk_dragable color; + append_el_to_body (el color); + + let brridget_grid : El.t = + El.div ~d:G.document + ~at:[ At.class' (Jstr.v "brridget-grid") ] + [ el text; el slider; el color ] + in + append_el_to_body brridget_grid; + () diff --git a/gadgetobrr.opam b/gadgetobrr.opam new file mode 100644 index 0000000..528025d --- /dev/null +++ b/gadgetobrr.opam @@ -0,0 +1,34 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Brr based library to help making input elements" +description: + "library based on Brr to make input elements and setup listeners on them to tweak values" +maintainer: ["swrup "] +authors: ["swrup "] +license: "ISC" +tags: ["topics" "js_of_ocaml" "brr" "widget"] +homepage: "https://forge.kumikode.org/swrup/gadgetobrr" +bug-reports: "https://forge.kumikode.org/swrup/gadgetobrr/issues" +depends: [ + "ocaml" + "dune" {>= "3.14"} + "js_of_ocaml" + "brr" + "tiny_httpd" {with-dev-setup} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://forge.kumikode.org/swrup/gadgetobrr.git" diff --git a/src/dune b/src/dune new file mode 100644 index 0000000..4fb7358 --- /dev/null +++ b/src/dune @@ -0,0 +1,4 @@ +(library + (name gadgetobrr) + (public_name gadgetobrr) + (libraries js_of_ocaml brr)) diff --git a/src/gadgetobrr.ml b/src/gadgetobrr.ml new file mode 100644 index 0000000..162b1a9 --- /dev/null +++ b/src/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

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
+  ()
diff --git a/src/gadgetobrr.mli b/src/gadgetobrr.mli
new file mode 100644
index 0000000..6e2b9a6
--- /dev/null
+++ b/src/gadgetobrr.mli
@@ -0,0 +1,70 @@
+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
+  }
+
+type _ t
+
+(** type for the step parameter of [mk_slider] Any is for continuous slider *)
+type step_kind =
+  | Any
+  | Step_value of float
+
+(** [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 "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
+  -> step:step_kind
+  -> value:float
+  -> id:string
+  -> label:string
+  -> datalist_id:string option
+  -> float t
+
+(** 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 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