swrup/gadgetobrr
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

init

Browse source
This commit is contained in:
Swrup 2024-04-11 15:46:46 +02:00
commit 2ff3fcaa49
15 changed files with 602 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored Normal file
View file

@ -0,0 +1 @@
_build/

42
.ocamlformat Normal file
View file

@ -0,0 +1,42 @@
version=0.28.1
assignment-operator=end-line
break-cases=fit
break-fun-decl=wrap
break-fun-sig=wrap
break-infix=wrap
break-infix-before-func=false
break-separators=before
break-sequences=true
cases-exp-indent=2
cases-matching-exp-indent=normal
doc-comments=before
doc-comments-padding=2
doc-comments-tag-only=default
dock-collection-brackets=false
exp-grouping=preserve
field-space=loose
if-then-else=compact
indicate-multiline-delimiters=space
indicate-nested-or-patterns=unsafe-no
infix-precedence=indent
leading-nested-match-parens=false
let-and=sparse
let-binding-spacing=compact
let-module=compact
margin=80
max-indent=68
module-item-spacing=sparse
ocp-indent-compat=false
parens-ite=false
parens-tuple=always
parse-docstrings=true
sequence-blank-line=preserve-one
sequence-style=terminator
single-case=compact
space-around-arrays=true
space-around-lists=true
space-around-records=true
space-around-variants=true
type-decl=sparse
wrap-comments=false
wrap-fun-args=true

8
LICENSE.md Normal file
View file

@ -0,0 +1,8 @@
The ISC License (ISC)
=====================
Copyright © 2024, swrup <swrup@protonmail.com>
Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

8
README.md Normal file
View file

@ -0,0 +1,8 @@
# gadgetobrr
utilitarian Brr based library to make widgets.
Help to create input elements and listen to input events on them
## TODOs
- use webstorage to make it work accross pages?

21
dune-project Normal file
View file

@ -0,0 +1,21 @@
(lang dune 3.14)
(name gadgetobrr)
(generate_opam_files true)
(authors "swrup <swrup@protonmail.com>")
(maintainers "swrup <swrup@protonmail.com>")
(license ISC)
(source
(uri git+https://forge.kumikode.org/swrup/gadgetobrr.git))
(homepage https://forge.kumikode.org/swrup/gadgetobrr)
(bug_reports https://forge.kumikode.org/swrup/gadgetobrr/issues)
(package
(name gadgetobrr)
(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")
(depends ocaml dune js_of_ocaml brr (tiny_httpd :with-dev-setup))
(tags
(topics js_of_ocaml brr widget)))

8
examples/content/dune Normal file
View file

@ -0,0 +1,8 @@
(rule
(target script.js)
(deps
(file ../script.bc.js))
(action
(with-stdout-to
%{target}
(cat ../script.bc.js))))

10
examples/content/index.html Normal file
View file

@ -0,0 +1,10 @@
<!DOCTYPE html>
<html>
<head>
<title>gadgetobrr</title>
<script src="/script.js" defer="defer"></script>
<link rel="stylesheet" href="/style.css">
</head>
<body>
</body>
</html>

19
examples/content/style.css Normal file
View file

@ -0,0 +1,19 @@
.brridget-container {
display: flex;
flex-direction: column;
top: 5vh;
left: 5vw;
background-color: black;
color: white;
opacity: 0.7;
padding-block: 2vh;
padding-inline: 1vw;
}
.brridget-grid {
display: grid;
position: fixed;
top: 5vh;
left: 4vw;
gap: 10%;
}

21
examples/dune Normal file
View file

@ -0,0 +1,21 @@
(executable
(name runweb)
(modules runweb content)
(libraries tiny_httpd))
(executable
(name script)
(modules script)
(libraries js_of_ocaml brr gadgetobrr)
(modes js))
(rule
(target content.ml)
(deps
(file content/index.html)
(file content/style.css)
(file content/script.js))
(action
(with-stdout-to
%{null}
(run ocaml-crunch -m plain content -o %{target}))))

29
examples/runweb.ml Normal file
View file

@ -0,0 +1,29 @@
module S = Tiny_httpd
let asset_loader path =
match Content.read path with None -> assert false | Some asset -> asset
let () =
let server = S.create ~port:8000 () in
S.add_route_handler ~meth:`GET server S.Route.return (fun _req ->
S.Response.make_string
~headers:[ ("Content-Type", "text/html") ]
(Ok (asset_loader "index.html")) );
S.add_route_handler ~meth:`GET server
S.Route.(exact "script.js" @/ return)
(fun _req ->
S.Response.make_string
~headers:[ ("Content-Type", "application/javascript") ]
(Ok (asset_loader "script.js")) );
S.add_route_handler ~meth:`GET server
S.Route.(exact "style.css" @/ return)
(fun _req ->
S.Response.make_string
~headers:[ ("Content-Type", "text/css") ]
(Ok (asset_loader "style.css")) );
Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server);
ignore @@ Sys.command "xdg-open http://localhost:8000";
ignore (match S.run server with Ok () -> () | Error e -> raise e)

58
examples/script.ml Normal file
View file

@ -0,0 +1,58 @@
(* This add a slidder to into <main>
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;
()

34
gadgetobrr.opam Normal file
View file

@ -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 <swrup@protonmail.com>"]
authors: ["swrup <swrup@protonmail.com>"]
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"

4
src/dune Normal file
View file

@ -0,0 +1,4 @@
(library
(name gadgetobrr)
(public_name gadgetobrr)
(libraries js_of_ocaml brr))

269
src/gadgetobrr.ml Normal file
View file

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

70
src/gadgetobrr.mli Normal file
View file

@ -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