Allow to customize icons

9 files changed, 339 insertions, 25 deletions

diff --git a/src/View/Button.ml b/src/View/Button.ml
new file mode 100644
index 0000000..31fa1b0
--- /dev/null
+++ b/src/View/Button.ml
@@ -0,0 +1,13 @@
+let action on_click label =
+  H.button
+      [| HA.class_ "g-Button__Action"
+      ;  HE.on_click on_click
+      |]
+      [| H.text label |]
+
+let danger on_click label =
+      H.button
+          [| HA.class_ "g-Button__Danger"
+          ;  HE.on_click on_click
+          |]
+          [| H.text label |]
diff --git a/src/View/Form.ml b/src/View/Form.ml
new file mode 100644
index 0000000..b0319b5
--- /dev/null
+++ b/src/View/Form.ml
@@ -0,0 +1,56 @@
+let section name =
+  H.h1
+    [| HA.class_ "g-Form__Section" |]
+    [| H.text name |]
+
+let input id label init_value on_input =
+  H.div
+    [| HA.class_ "g-Form__Field" |]
+    [| H.div
+        [| HA.class_ "g-Form__Label" |]
+        [| H.label
+          [| 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
+        |]
+        [| |]
+    |]
+
+let color_input id label init_value on_input =
+  H.div
+    [| HA.class_ "g-Form__Field" |]
+    [| H.div
+        [| HA.class_ "g-Form__Label" |]
+        [| H.label
+          [| 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"
+        |]
+        [| |]
+    |]
+
+let textarea id label init_value on_input =
+  H.div
+    [| HA.class_ "g-Form__Field" |]
+    [| H.div
+        [| HA.class_ "g-Form__Label" |]
+        [| H.label
+          [| HA.for_ id |]
+          [| H.text label |]
+        |]
+    ;  H.textarea
+        [| HA.id id
+        ;  HA.class_ "g-Form__Textarea"
+        ;  HE.on_input (fun e -> on_input (Element.value (Event.target e)))
+        |]
+        [| H.text init_value |]
+    |]
diff --git a/src/View/Form/Autocomplete.ml b/src/View/Form/Autocomplete.ml
new file mode 100644
index 0000000..537316d
--- /dev/null
+++ b/src/View/Form/Autocomplete.ml
@@ -0,0 +1,62 @@
+let search s xs =
+  if s == "" then
+    [| |]
+  else
+    let results = Js.Array.filter (Js.String.includes s) xs in
+    if Js.Array.length results == 1 && results.(0) == s then [| |] else results
+
+let render_completion on_select entries =
+  H.div
+    [| HA.class_ "g-Autocomplete__Completion" |]
+    (entries
+      |> Js.Array.map (fun c ->
+          H.button
+            [| HA.class_ "g-Autocomplete__Entry"
+            ;  HA.type_ "button"
+            ;  HE.on_click (fun _ -> on_select c)
+            |]
+            [| H.text c |]))
+
+let create id label values on_input attrs =
+
+  let completion =
+    H.div [| |] [| |]
+  in
+
+  let update_completion target value =
+    let entries = search value values in
+    Element.mount_on completion (render_completion
+      (fun selected ->
+        let () = Element.set_value target selected in
+        let () = Element.remove_children completion in
+        on_input selected)
+      entries)
+  in
+
+  H.div
+    [| HA.class_ "g-Autocomplete" |]
+    [| H.div
+        [| HA.class_ "g-Form__Label" |]
+        [| H.label
+          [| HA.for_ id |]
+          [| H.text label |]
+        |]
+    ; H.input
+      (Js.Array.concat
+        [| HA.id id
+        ; HA.class_ "g-Autocomplete__Input"
+        ; HA.autocomplete "off"
+        ;  HE.on_click (fun e ->
+            let target = Event.target e in
+            let value = Element.value target in
+            update_completion target value)
+        ;  HE.on_input (fun e ->
+            let target = Event.target e in
+            let value = Element.value target in
+            let () = update_completion target value in
+            on_input value)
+        |]
+        attrs)
+      [| |]
+    ;  completion
+    |]
diff --git a/src/View/Layout.ml b/src/View/Layout.ml
new file mode 100644
index 0000000..98218ad
--- /dev/null
+++ b/src/View/Layout.ml
@@ -0,0 +1,4 @@
+let section attrs content =
+  H.div
+    (Js.Array.concat [| HA.class_ "g-Layout__Section" |] attrs)
+    content
diff --git a/src/View/Map.ml b/src/View/Map.ml
index bcd0506..969a95a 100644
--- a/src/View/Map.ml
+++ b/src/View/Map.ml
@@ -1,28 +1,87 @@
-let render () =
-  let
-    _ =
-      Js.Global.setTimeout
-        (fun () ->
-          let map = Leaflet.map("g-Map__Content") in
-          let tileLayer = Leaflet.tileLayer "http://{s}.tile.osm.org/{z}/{x}/{y}.png" in
-          let () = Leaflet.addTo tileLayer map in
-          let () = Leaflet.setView map [| 51.505; -0.09 |] 13 in
-          Leaflet.on map "contextmenu" (fun (event) ->
-            Leaflet.addTo (Leaflet.marker (Leaflet.latLng event) { title = "Hey"; }) map))
-        0
-  in
+let mapView =
   H.div
-    ~attributes:[| H.className "g-Layout__Page" |]
-    ~children: [|
-      H.div
-        ~attributes:[| H.className "g-Layout__Header" |]
-        ~children:[| H.text "Map" |]
-        ();
-      H.div
-        ~attributes:[| H.className "g-Map" |]
-        ~children:[|
-          H.div ~attributes:[| H.id "g-Map__Content" |] ()
+    [| HA.class_ "g-Layout__Page" |]
+    [| H.div
+        [| HA.class_ "g-Layout__Header" |]
+        [| H.a
+            [| HA.class_ "g-Layout__Home"
+            ;  HA.href "#"
+            |]
+            [| H.text "Map" |]
+        |]
+    ; H.div
+        [| HA.class_ "g-Map" |]
+        [| H.div
+            [| HA.id "g-Map__Content" |]
+            [||]
         |]
-        ();
     |]
-    ()
+
+let state_from_hash () =
+  let hash = Js.String.sliceToEnd ~from:1 (Location.hash Document.location) in
+  State.from_string hash
+
+let installMap () =
+  let state = ref (state_from_hash ()) in
+  let map = Leaflet.map "g-Map__Content" in
+  let title_layer = Leaflet.title_layer "http://{s}.tile.osm.org/{z}/{x}/{y}.png" in
+  let markers = Leaflet.feature_group [| |] in
+  let () = Leaflet.add_layer map markers in
+  let () = Leaflet.add_layer map title_layer in
+
+  let rec reload_from_hash focus =
+    let update_state new_state =
+      let () = History.push_state "" "" ("#" ^ State.to_string new_state) () in
+      reload_from_hash false
+    in
+
+    let on_remove pos =
+      update_state (State.remove !state pos) in
+
+    let on_update previousPos pos name color icon =
+      update_state (State.update !state previousPos { pos = pos; name = name; color = color; icon = icon }) in
+
+    let () =
+      if Js.Array.length (Leaflet.get_layers markers ()) > 0 then
+        Leaflet.clear_layers markers
+      else
+        ()
+    in
+    let () = state := state_from_hash () 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))
+        !state
+    in
+    if focus then
+      if Js.Array.length (Leaflet.get_layers markers ()) > 0 then
+        Leaflet.fit_bounds map (Leaflet.get_bounds markers ()) { padding = [| 50.; 50. |] }
+      else
+        Leaflet.setView map [| 51.505; -0.09 |] 2
+    else
+      ()
+  in
+
+  (* Init markers from url *)
+  let () = reload_from_hash true in
+
+  (* Reload the map if the URL changes *)
+  let () = Element.addEventListener Window.window "popstate" (fun _ ->
+    reload_from_hash true)
+  in
+
+  (* Add a marker on right click *)
+  Leaflet.on map "contextmenu" (fun (event) ->
+    let pos = Leaflet.lat_lng event in
+    let new_marker =
+      match State.last_added !state with
+      | Some m -> { m with pos = pos; name = "" }
+      | None -> { pos = pos; name = ""; color = "#3f92cf"; icon = "" }
+    in
+    let new_state = State.update !state pos new_marker in
+    let () = History.push_state "" "" ("#" ^ State.to_string new_state) () in
+    reload_from_hash false)
+
+let render () =
+  let _ = Js.Global.setTimeout installMap 0 in
+  mapView
diff --git a/src/View/Map/Icon.ml b/src/View/Map/Icon.ml
new file mode 100644
index 0000000..9b1f40a
--- /dev/null
+++ b/src/View/Map/Icon.ml
@@ -0,0 +1,32 @@
+let create name color =
+  let c = Color.from_raw color in
+  let crBlack = Color.contrast_ratio { r = 0.; g = 0.; b = 0. } c in
+  let crWhite = Color.contrast_ratio { r = 255.; g = 255.; b = 255. } c in
+  let textCol = if crBlack > crWhite then "black" else "white" in
+  Leaflet.div_icon
+    { className = "marker-parent"
+    ; popupAnchor = [| 0.; -34. |]
+    ; html =
+        H.div
+          [| |]
+          [| H.div
+              [| HA.class_ "marker-round"
+              ;  HA.style ("background-color: " ^ color)
+              |]
+              [| |]
+          ;  H.div [| HA.class_ "marker-peak-border" |] [| |]
+          ;  H.div
+              [| HA.class_ "marker-peak-inner"
+              ;  HA.style ("border-top-color: " ^ color)
+              |]
+              [| |]
+          ;  H.div
+              [| HA.class_ "marker-icon" |]
+              [| H.i
+                  [| HA.class_ ("fa fa-" ^ name)
+                  ;  HA.style ("color: " ^ textCol)
+                  |]
+                  [| |]
+              |]
+          |]
+    }
diff --git a/src/View/Map/Marker.ml b/src/View/Map/Marker.ml
new file mode 100644
index 0000000..a96af86
--- /dev/null
+++ b/src/View/Map/Marker.ml
@@ -0,0 +1,61 @@
+let create on_remove on_update pos init_name init_color init_icon =
+  let marker =
+        Leaflet.marker pos
+          { title = init_name
+          ; icon = Icon.create init_icon init_color
+          ; draggable = true
+          }
+  in
+  let form on_remove on_update =
+    let name = ref init_name in
+    let color = ref init_color in
+    let icon = ref init_icon in
+    let on_update () =
+          let () = on_update pos pos !name !color !icon in
+          Modal.hide ()
+    in
+    H.div
+      [| |]
+      [| Layout.section
+          [| |]
+          [| H.form
+              [| HA.class_ "g-MarkerForm"
+              ;  HE.on_submit (fun e ->
+                  let () = Event.preventDefault e in
+                  on_update ())
+              |]
+              [| Form.section "Modification"
+              ;  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)
+                  ;  Autocomplete.create
+                      "g-MarkerForm__Icon"
+                      "Icon"
+                      FontAwesome.icons
+                      (fun newIcon -> let () = Js.log newIcon in icon := newIcon)
+                      [| HA.value init_icon |]
+                  |]
+              ;  Button.action (fun _ -> on_update ()) "Modify"
+              |]
+          |]
+      ;  Layout.section
+          [| |]
+          [| Form.section "Deletion"
+          ;  Button.danger (fun _ ->
+                let () = on_remove pos in
+                Modal.hide ()) "Remove"
+          |]
+      |]
+  in
+
+  (* Open a modification / deletion modal on click *)
+  let () = Leaflet.on marker "click" (fun _ ->
+    Modal.show (form on_remove on_update)) in
+
+  (* Move the cursor on drag *)
+  let () = Leaflet.on marker "dragend" (fun e ->
+    let newPos = Leaflet.get_lat_lng (Leaflet.target e) () in
+    on_update pos newPos init_name init_color init_icon) in
+
+  marker
diff --git a/src/View/Map/MarkerForm.ml b/src/View/Map/MarkerForm.ml
deleted file mode 100644
index e69de29..0000000
--- a/src/View/Map/MarkerForm.ml
+++ /dev/null
diff --git a/src/View/Modal.ml b/src/View/Modal.ml
new file mode 100644
index 0000000..9365555
--- /dev/null
+++ b/src/View/Modal.ml
@@ -0,0 +1,27 @@
+let hide () =
+  let body = Document.querySelectorUnsafe "body" in
+  let modal = Document.querySelectorUnsafe ".g-Modal" in
+  Element.removeChild body modal
+
+let show content =
+  let body = Document.querySelectorUnsafe "body" in
+  let view =
+    H.div
+      [| HA.class_ "g-Modal" |]
+      [| H.div
+          [| HA.class_ "g-Modal__Curtain"
+          ;  HE.on_click (fun _ -> hide ())
+          |]
+          [| |]
+      ;  H.div
+          [| HA.class_ "g-Modal__Window" |]
+          [| H.button
+              [| HA.class_ "g-Modal__Close"
+              ;  HE.on_click (fun _ -> hide ())
+              |]
+              [| H.text "X" |]
+          ;  content
+          |]
+      |]
+  in
+  Element.appendChild body view