aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Lib/Dom/HA.ml18
-rw-r--r--src/Lib/Modal.ml2
-rw-r--r--src/State.ml11
-rw-r--r--src/View/Button.ml14
-rw-r--r--src/View/Colors.ml4
-rw-r--r--src/View/Form.ml31
-rw-r--r--src/View/Form/Autocomplete.ml8
-rw-r--r--src/View/Layout.ml4
-rw-r--r--src/View/Map.ml9
-rw-r--r--src/View/Map/Marker.ml17
10 files changed, 94 insertions, 24 deletions
diff --git a/src/Lib/Dom/HA.ml b/src/Lib/Dom/HA.ml
index a7a45ce..53fb84d 100644
--- a/src/Lib/Dom/HA.ml
+++ b/src/Lib/Dom/HA.ml
@@ -1,3 +1,21 @@
+let concat xs ys =
+ let partition_class =
+ Js.Array.reduce
+ (fun (class_acc, rest_acc) z ->
+ match z with
+ | H.TextAttr ("class", c) -> (class_acc ^ " " ^ c, rest_acc)
+ | _ -> (class_acc, Js.Array.concat [| z |] rest_acc)
+ )
+ ("", [| |])
+ in
+ let (xs_class, xs_rest) = partition_class xs in
+ let (ys_class, ys_rest) = partition_class ys in
+ let rest = Js.Array.concat xs_rest ys_rest in
+ if xs_class == "" && ys_class == "" then
+ rest
+ else
+ Js.Array.concat [| H.TextAttr ("class", xs_class ^ " " ^ ys_class) |] rest
+
(* Attribute creation *)
let id v = H.TextAttr ("id", v)
diff --git a/src/Lib/Modal.ml b/src/Lib/Modal.ml
index 3fa0550..5db88cd 100644
--- a/src/Lib/Modal.ml
+++ b/src/Lib/Modal.ml
@@ -13,7 +13,7 @@ let show content =
[| |]
; H.div
[| HA.class_ "g-Modal__Window" |]
- [| H.button
+ [| Button.raw
[| HA.class_ "g-Modal__Close"
; HE.on_click (fun _ -> hide ())
|]
diff --git a/src/State.ml b/src/State.ml
index cc20b16..59391d2 100644
--- a/src/State.ml
+++ b/src/State.ml
@@ -59,3 +59,14 @@ let from_string str =
("", [| |], [| |])
(Js.Array.from (Js.String.castToArrayLike ((String.decode str) ^ sep)))
in res
+
+(* Colors *)
+
+let colors =
+ Js.Array.reduce
+ (fun colors marker ->
+ if Js.Array.indexOf marker.color colors == -1 then
+ Js.Array.concat [| marker.color |] colors
+ else
+ colors)
+ [| |]
diff --git a/src/View/Button.ml b/src/View/Button.ml
index c325fdd..723b7d1 100644
--- a/src/View/Button.ml
+++ b/src/View/Button.ml
@@ -1,9 +1,19 @@
+let raw attrs content =
+ H.button
+ (HA.concat attrs [| HA.class_ "g-Button__Raw" |])
+ content
+
+let text attrs content =
+ H.button
+ (HA.concat attrs [| HA.class_ "g-Button__Text" |])
+ content
+
let action attrs content =
H.button
- (Js.Array.concat attrs [| HA.class_ "g-Button__Action" |])
+ (HA.concat attrs [| HA.class_ "g-Button__Action" |])
content
let cancel attrs content =
H.button
- (Js.Array.concat attrs [| HA.class_ "g-Button__Cancel" |])
+ (HA.concat attrs [| HA.class_ "g-Button__Cancel" |])
content
diff --git a/src/View/Colors.ml b/src/View/Colors.ml
new file mode 100644
index 0000000..380a01c
--- /dev/null
+++ b/src/View/Colors.ml
@@ -0,0 +1,4 @@
+let content () =
+ H.div
+ [| |]
+ [| H.text "Colors" |]
diff --git a/src/View/Form.ml b/src/View/Form.ml
index db73b0c..cc95210 100644
--- a/src/View/Form.ml
+++ b/src/View/Form.ml
@@ -15,7 +15,17 @@ let input id label init_value on_input =
[| |]
|]
-let color_input id label init_value on_input =
+let color_input default_colors id label init_value on_input =
+ let
+ input =
+ H.input
+ [| HA.id id
+ ; HE.on_input (fun e -> on_input (Element.value (Event.target e)))
+ ; HA.value init_value
+ ; HA.type_ "color"
+ |]
+ [| |]
+ in
H.div
[| HA.class_ "g-Form__Field" |]
[| H.div
@@ -24,13 +34,20 @@ let color_input id label init_value on_input =
[| HA.for_ id |]
[| H.text label |]
|]
- ; H.input
- [| HA.id id
- ; HE.on_input (fun e -> on_input (Element.value (Event.target e)))
- ; HA.value init_value
- ; HA.type_ "color"
- |]
+ ; Layout.line
[| |]
+ (default_colors
+ |> Js.Array.map (fun color ->
+ Button.raw
+ [| HA.class_ "g-Form__DefaultColor"
+ ; HA.style ("background-color: " ^ color)
+ ; HE.on_click (fun _ ->
+ let () = Element.set_value input color in
+ on_input color)
+ ; HA.type_ "button"
+ |]
+ [| |])
+ |> (fun xs -> Js.Array.concat xs [| input |]))
|]
let textarea id label init_value on_input =
diff --git a/src/View/Form/Autocomplete.ml b/src/View/Form/Autocomplete.ml
index 324a834..2770e16 100644
--- a/src/View/Form/Autocomplete.ml
+++ b/src/View/Form/Autocomplete.ml
@@ -7,7 +7,7 @@ let render_completion render_entry on_select entries =
[| HA.class_ "g-Autocomplete__Completion" |]
(entries
|> Js.Array.map (fun c ->
- H.button
+ Button.raw
[| HA.class_ "g-Autocomplete__Entry"
; HA.type_ "button"
; HE.on_click (fun e ->
@@ -41,7 +41,8 @@ let create attrs id values render_entry on_input =
H.div
[| HA.class_ "g-Autocomplete" |]
[| H.input
- (Js.Array.concat
+ (HA.concat
+ attrs
[| HA.id id
; HA.class_ "g-Autocomplete__Input"
; HA.autocomplete "off"
@@ -59,8 +60,7 @@ let create attrs id values render_entry on_input =
(fun _ -> hide_completion ())
100
in ())
- |]
- attrs)
+ |])
[| |]
; completion
|]
diff --git a/src/View/Layout.ml b/src/View/Layout.ml
index b217f0b..db1e234 100644
--- a/src/View/Layout.ml
+++ b/src/View/Layout.ml
@@ -1,9 +1,9 @@
let section attrs content =
H.div
- (Js.Array.concat [| HA.class_ "g-Layout__Section" |] attrs)
+ (HA.concat attrs [| HA.class_ "g-Layout__Section" |])
content
let line attrs content =
H.div
- (Js.Array.concat [| HA.class_ "g-Layout__Line" |] attrs)
+ (HA.concat attrs [| HA.class_ "g-Layout__Line" |])
content
diff --git a/src/View/Map.ml b/src/View/Map.ml
index b46557d..678f5ae 100644
--- a/src/View/Map.ml
+++ b/src/View/Map.ml
@@ -8,6 +8,9 @@ let mapView =
; HA.href "#"
|]
[| H.text "Map" |]
+ ; Button.text
+ [| HE.on_click (fun _ -> Modal.show (Colors.content ())) |]
+ [| H.text "Colors" |]
|]
; H.div
[| HA.class_ "g-Map" |]
@@ -48,9 +51,10 @@ let installMap () =
()
in
let () = state := state_from_hash () in
+ let colors = State.colors !state in
let () =
Js.Array.forEach
- (fun (m: State.marker_state) -> Leaflet.add_layer markers (Marker.create on_remove on_update m.pos m.name m.color m.icon))
+ (fun (m: State.marker_state) -> Leaflet.add_layer markers (Marker.create on_remove on_update colors m.pos m.name m.color m.icon))
!state
in
if focus then
@@ -89,7 +93,8 @@ let installMap () =
| Some m -> { m with pos = pos; name = "" }
| _ -> { pos = pos; name = ""; color = "#3f92cf"; icon = "" }
in
- Modal.show (Marker.form (add_marker pos) marker.name marker.color marker.icon))
+ let colors = State.colors !state in
+ Modal.show (Marker.form (add_marker pos) colors marker.name marker.color marker.icon))
}
|])
diff --git a/src/View/Map/Marker.ml b/src/View/Map/Marker.ml
index e793742..80072af 100644
--- a/src/View/Map/Marker.ml
+++ b/src/View/Map/Marker.ml
@@ -1,4 +1,4 @@
-let form on_validate init_name init_color init_icon =
+let form on_validate colors init_name init_color init_icon =
let name = ref init_name in
let color = ref init_color in
let icon = ref init_icon in
@@ -19,7 +19,7 @@ let form on_validate init_name init_color init_icon =
[| Layout.section
[| |]
[| Form.input "g-MarkerForm__Name" "Name" init_name (fun newName -> name := newName)
- ; Form.color_input "g-MarkerForm__Color" "Color" init_color (fun newColor -> color := newColor)
+ ; Form.color_input colors "g-MarkerForm__Color" "Color" init_color (fun newColor -> color := newColor)
; H.div
[| HA.class_ "g-Form__Field" |]
[| H.div
@@ -59,7 +59,7 @@ let form on_validate init_name init_color init_icon =
|]
-let create on_remove on_update pos init_name init_color init_icon =
+let create on_remove on_update colors pos init_name init_color init_icon =
let marker =
Leaflet.marker pos
{ title = init_name
@@ -72,8 +72,13 @@ let create on_remove on_update pos init_name init_color init_icon =
let () = Leaflet.on marker "contextmenu" (fun event ->
ContextMenu.show
(Leaflet.original_event event)
- [| { label = "Modify"; action = fun _ -> Modal.show (form (on_update pos pos) init_name init_color init_icon) }
- ; { label = "Remove"; action = fun _ -> on_remove pos }
+ [| { label = "Modify"
+ ; action = fun _ ->
+ Modal.show (form (on_update pos pos) colors init_name init_color init_icon)
+ }
+ ; { label = "Remove"
+ ; action = fun _ -> on_remove pos
+ }
|])
in
@@ -83,6 +88,6 @@ let create on_remove on_update pos init_name init_color init_icon =
on_update pos newPos init_name init_color init_icon) in
let () = Leaflet.on marker "dblclick" (fun _ ->
- Modal.show (form (on_update pos pos) init_name init_color init_icon)) in
+ Modal.show (form (on_update pos pos) colors init_name init_color init_icon)) in
marker
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 05:36:24 +0000