Propose already defined colors in the form

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