gadgetobrr/lib/gadgetobrr.ml

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
  ()