Show context menu to add, modify and delete markers

15 files changed, 191 insertions, 128 deletions

diff --git a/src/Color.ml b/src/Color.ml
index b3d2f91..d2f74c4 100644
--- a/src/Color.ml
+++ b/src/Color.ml
@@ -27,10 +27,10 @@ let contrast_ratio (c1: rgb) (c2: rgb) =
 let from_raw color =
   let get_opt = function | Some x -> x | None -> raise (Invalid_argument "Option.get") in
   let div = H.div [| HA.style ("color: " ^ color) |] [| |] in
-  let body = Document.querySelectorUnsafe "body" in
-  let () = Element.appendChild body div in
+  let body = Document.query_selector_unsafe "body" in
+  let () = Element.append_child body div in
   let rgb = [%raw {| window.getComputedStyle(div).color |}] in
-  let () = Element.removeChild body div in
+  let () = Element.remove_child body div in
   let xs = Js.String.split ", " (get_opt (Js.String.splitByRe [%re "/[()]/"] rgb).(1)) in
   { r = Js.Float.fromString xs.(0)
   ; g = Js.Float.fromString xs.(1)
diff --git a/src/Lib/ContextMenu.ml b/src/Lib/ContextMenu.ml
new file mode 100644
index 0000000..b9ed7d4
--- /dev/null
+++ b/src/Lib/ContextMenu.ml
@@ -0,0 +1,40 @@
+let px f =
+  Js.Float.toString f ^ "px"
+
+type entry =
+  { label: string
+  ; action: unit -> unit
+  }
+
+let show mouse_event actions =
+  let menu =
+    H.div
+      [| HA.id "g-ContextMenu"
+      ;  HA.style ("left: " ^ (px (Event.page_x mouse_event)) ^ "; top: " ^ (px (Event.page_y mouse_event)))
+      |]
+      (Js.Array.map
+        (fun entry ->
+          H.div
+            [| HA.class_ "g-ContextMenu__Entry"
+            ;  HE.on_click (fun _ -> entry.action ())
+            |]
+            [| H.text entry.label |])
+        actions)
+  in
+  let () = Element.append_child Document.body menu in
+
+  (* Remove on click or context menu *)
+  let _ =
+    Js.Global.setTimeout
+      (fun _ ->
+        let rec f = (fun _ ->
+          let () = Element.remove_child Document.body menu in
+          let () = Element.remove_event_listener Document.body "click" f in
+          Element.remove_event_listener Document.body "contextmenu" f)
+        in
+        let () = Element.add_event_listener Document.body "click" f in
+        Element.add_event_listener Document.body "contextmenu" f
+      )
+      0
+  in
+  ()
diff --git a/src/Lib/Dom/Document.ml b/src/Lib/Dom/Document.ml
index 39c1bb4..46f983a 100644
--- a/src/Lib/Dom/Document.ml
+++ b/src/Lib/Dom/Document.ml
@@ -1,16 +1,19 @@
-external createElement : string -> Dom.element = "createElement"
+external body : Dom.element = "body"
   [@@bs.val] [@@bs.scope "document"]
 
-external createElementNS : string -> string -> Dom.element = "createElementNS"
+external create_element : string -> Dom.element = "createElement"
   [@@bs.val] [@@bs.scope "document"]
 
-external querySelector : string -> Dom.element Js.Nullable.t = "querySelector"
+external create_element_ns : string -> string -> Dom.element = "createElementNS"
   [@@bs.val] [@@bs.scope "document"]
 
-let querySelectorUnsafe id =
-  querySelector id |> Js.Nullable.toOption |> Js.Option.getExn
+external query_selector : string -> Dom.element Js.Nullable.t = "querySelector"
+  [@@bs.val] [@@bs.scope "document"]
+
+let query_selector_unsafe id =
+  query_selector id |> Js.Nullable.toOption |> Js.Option.getExn
 
-external createTextNode : string -> Dom.element = "createTextNode"
+external create_text_node : string -> Dom.element = "createTextNode"
   [@@bs.val] [@@bs.scope "document"]
 
 external location : Location.location = "location"
diff --git a/src/Lib/Dom/Element.ml b/src/Lib/Dom/Element.ml
index a72b783..391a95c 100644
--- a/src/Lib/Dom/Element.ml
+++ b/src/Lib/Dom/Element.ml
@@ -2,43 +2,36 @@ external set_value : Dom.element -> string -> unit = "value" [@@bs.set]
 
 external value : Dom.element -> string = "value" [@@bs.get]
 
-external setTextContent : Dom.element -> string -> unit = "textContent"
-  [@@bs.set]
-
-external setStyle : Dom.element -> string -> unit = "style" [@@bs.set]
-
-external setClassName : Dom.element -> string -> unit = "className" [@@bs.set]
-
-external setAttribute : Dom.element -> string -> string -> unit = "setAttribute"
+external set_attribute : Dom.element -> string -> string -> unit = "setAttribute"
   [@@bs.send]
 
-external setAttributeNS : Dom.element -> string -> string -> string -> unit
-  = "setAttributeNS"
+external add_event_listener : Dom.element -> string -> (Dom.event -> unit) -> unit
+  = "addEventListener"
   [@@bs.send]
 
-external addEventListener : Dom.element -> string -> (Dom.event -> unit) -> unit
-  = "addEventListener"
+external remove_event_listener : Dom.element -> string -> (Dom.event -> unit) -> unit
+  = "removeEventListener"
   [@@bs.send]
 
-external appendChild : Dom.element -> Dom.element -> unit = "appendChild"
+external append_child : Dom.element -> Dom.element -> unit = "appendChild"
   [@@bs.send]
 
-external firstChild : Dom.element -> Dom.element Js.Nullable.t = "firstChild"
+external first_child : Dom.element -> Dom.element Js.Nullable.t = "firstChild"
   [@@bs.get]
 
-external removeChild : Dom.element -> Dom.element -> unit = "removeChild"
+external remove_child : Dom.element -> Dom.element -> unit = "removeChild"
   [@@bs.send]
 
-let removeFirstChild element =
-  match Js.toOption (firstChild element) with
+let remove_first_child element =
+  match Js.toOption (first_child element) with
   | Some child ->
-      let () = removeChild element child in
+      let () = remove_child element child in
       true
   | _ -> false
 
 let rec remove_children element =
-  if removeFirstChild element then remove_children element else ()
+  if remove_first_child element then remove_children element else ()
 
 let mount_on base element =
   let () = remove_children base in
-  appendChild base element
+  append_child base element
diff --git a/src/Lib/Dom/Event.ml b/src/Lib/Dom/Event.ml
index acdc9fd..861afcf 100644
--- a/src/Lib/Dom/Event.ml
+++ b/src/Lib/Dom/Event.ml
@@ -1,3 +1,11 @@
-external preventDefault : Dom.event -> unit = "preventDefault" [@@bs.send]
+external prevent_default : Dom.event -> unit = "preventDefault"
+  [@@bs.send]
 
-external target : Dom.event -> Dom.element = "target" [@@bs.get]
+external target : Dom.event -> Dom.element = "target"
+  [@@bs.get]
+
+external page_x : Dom.mouseEvent -> float = "pageX"
+  [@@bs.get]
+
+external page_y : Dom.mouseEvent -> float = "pageY"
+  [@@bs.get]
diff --git a/src/Lib/Dom/H.ml b/src/Lib/Dom/H.ml
index d547a70..7213daf 100644
--- a/src/Lib/Dom/H.ml
+++ b/src/Lib/Dom/H.ml
@@ -7,30 +7,30 @@ type attribute =
 let h tag attributes children =
   let element =
     if tag == "svg" || tag == "path" then
-      Document.createElementNS "http://www.w3.org/2000/svg" tag
-    else Document.createElement tag
+      Document.create_element_ns "http://www.w3.org/2000/svg" tag
+    else Document.create_element tag
   in
   let () =
     Js.Array.forEach
       (fun attr ->
         match attr with
           | TextAttr (name, value) ->
-              Element.setAttribute element name value
+              Element.set_attribute element name value
 
           | EventAttr (name, eventListener) ->
-              Element.addEventListener element name eventListener)
+              Element.add_event_listener element name eventListener)
       attributes
   in
   let () =
     Js.Array.forEach
-      (fun child -> Element.appendChild element child)
+      (fun child -> Element.append_child element child)
       children
   in
   element
 
 (* Node creation *)
 
-let text = Document.createTextNode
+let text = Document.create_text_node
 
 let div = h "div"
 
diff --git a/src/Lib/Leaflet.ml b/src/Lib/Leaflet.ml
index a8a8978..0cc7976 100644
--- a/src/Lib/Leaflet.ml
+++ b/src/Lib/Leaflet.ml
@@ -16,6 +16,9 @@ type lat_lng =
     lng : float;
   }
 
+external original_event : event -> Dom.mouseEvent = "originalEvent"
+  [@@bs.get]
+
 external lat_lng : event -> lat_lng = "latlng"
   [@@bs.get]
 
diff --git a/src/View/Modal.ml b/src/Lib/Modal.ml
index 9365555..3fa0550 100644
--- a/src/View/Modal.ml
+++ b/src/Lib/Modal.ml
@@ -1,13 +1,11 @@
 let hide () =
-  let body = Document.querySelectorUnsafe "body" in
-  let modal = Document.querySelectorUnsafe ".g-Modal" in
-  Element.removeChild body modal
+  let modal = Document.query_selector_unsafe "#g-Modal" in
+  Element.remove_child Document.body modal
 
 let show content =
-  let body = Document.querySelectorUnsafe "body" in
   let view =
     H.div
-      [| HA.class_ "g-Modal" |]
+      [| HA.id "g-Modal" |]
       [| H.div
           [| HA.class_ "g-Modal__Curtain"
           ;  HE.on_click (fun _ -> hide ())
@@ -19,9 +17,9 @@ let show content =
               [| HA.class_ "g-Modal__Close"
               ;  HE.on_click (fun _ -> hide ())
               |]
-              [| H.text "X" |]
+              [| H.div [| HA.class_ "fa fa-close" |] [| |] |]
           ;  content
           |]
       |]
   in
-  Element.appendChild body view
+  Element.append_child Document.body view
diff --git a/src/Main.ml b/src/Main.ml
index b95d01f..9216b35 100644
--- a/src/Main.ml
+++ b/src/Main.ml
@@ -1,3 +1,3 @@
 let () =
-  let body = Document.querySelectorUnsafe "body" in
-  Element.appendChild body (Map.render ())
+  let body = Document.query_selector_unsafe "body" in
+  Element.append_child body (Map.render ())
diff --git a/src/View/Button.ml b/src/View/Button.ml
index 31fa1b0..c325fdd 100644
--- a/src/View/Button.ml
+++ b/src/View/Button.ml
@@ -1,13 +1,9 @@
-let action on_click label =
+let action attrs content =
   H.button
-      [| HA.class_ "g-Button__Action"
-      ;  HE.on_click on_click
-      |]
-      [| H.text label |]
+    (Js.Array.concat attrs [| HA.class_ "g-Button__Action" |])
+    content
 
-let danger on_click label =
-      H.button
-          [| HA.class_ "g-Button__Danger"
-          ;  HE.on_click on_click
-          |]
-          [| H.text label |]
+let cancel attrs content =
+  H.button
+    (Js.Array.concat attrs [| HA.class_ "g-Button__Cancel" |])
+    content
diff --git a/src/View/Form.ml b/src/View/Form.ml
index b0319b5..db73b0c 100644
--- a/src/View/Form.ml
+++ b/src/View/Form.ml
@@ -1,8 +1,3 @@
-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" |]
diff --git a/src/View/Layout.ml b/src/View/Layout.ml
index 98218ad..b217f0b 100644
--- a/src/View/Layout.ml
+++ b/src/View/Layout.ml
@@ -2,3 +2,8 @@ let section attrs content =
   H.div
     (Js.Array.concat [| HA.class_ "g-Layout__Section" |] attrs)
     content
+
+let line attrs content =
+  H.div
+    (Js.Array.concat [| HA.class_ "g-Layout__Line" |] attrs)
+    content
diff --git a/src/View/Map.ml b/src/View/Map.ml
index 969a95a..b46557d 100644
--- a/src/View/Map.ml
+++ b/src/View/Map.ml
@@ -66,21 +66,32 @@ let installMap () =
   let () = reload_from_hash true in
 
   (* Reload the map if the URL changes *)
-  let () = Element.addEventListener Window.window "popstate" (fun _ ->
+  let () = Element.add_event_listener 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 add_marker pos name color icon =
+    let new_marker = { State.pos = pos; name = name; color = color; icon = 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)
+    reload_from_hash false
+  in
+
+  (* Context menu *)
+  Leaflet.on map "contextmenu" (fun event ->
+    ContextMenu.show
+      (Leaflet.original_event event)
+      [| { label = "Add a marker"
+         ; action = (fun _ ->
+             let pos = Leaflet.lat_lng event in
+             let marker =
+               match State.last_added !state with
+               | 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 render () =
   let _ = Js.Global.setTimeout installMap 0 in
diff --git a/src/View/Map/Icon.ml b/src/View/Map/Icon.ml
index 9b1f40a..8737f43 100644
--- a/src/View/Map/Icon.ml
+++ b/src/View/Map/Icon.ml
@@ -4,24 +4,24 @@ let create name color =
   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"
+    { className = ""
     ; popupAnchor = [| 0.; -34. |]
     ; html =
         H.div
-          [| |]
+          [| HA.class_ "g-Marker" |]
           [| H.div
-              [| HA.class_ "marker-round"
+              [| HA.class_ "g-Marker__Round"
               ;  HA.style ("background-color: " ^ color)
               |]
               [| |]
-          ;  H.div [| HA.class_ "marker-peak-border" |] [| |]
+          ;  H.div [| HA.class_ "g-Marker__PeakBorder" |] [| |]
           ;  H.div
-              [| HA.class_ "marker-peak-inner"
+              [| HA.class_ "g-Marker__PeakInner"
               ;  HA.style ("border-top-color: " ^ color)
               |]
               [| |]
           ;  H.div
-              [| HA.class_ "marker-icon" |]
+              [| HA.class_ "g-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
index a96af86..58ec4bd 100644
--- a/src/View/Map/Marker.ml
+++ b/src/View/Map/Marker.ml
@@ -1,61 +1,72 @@
+let form on_validate init_name init_color init_icon =
+  let name = ref init_name in
+  let color = ref init_color in
+  let icon = ref init_icon in
+  let on_validate () =
+        let () = on_validate !name !color !icon in
+        Modal.hide ()
+  in
+  H.div
+    [| |]
+    [| Layout.section
+        [| |]
+        [| H.form
+            [| HA.class_ "g-MarkerForm"
+            ;  HE.on_submit (fun e ->
+                let () = Event.prevent_default e in
+                on_validate ())
+            |]
+            [| 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 |]
+                |]
+            ;  Layout.line
+                [| |]
+                [| Button.action
+                    [| HE.on_click (fun _ -> on_validate ()) |]
+                    [| H.text "Save" |]
+                ;  Button.cancel
+                    [| HE.on_click (fun _ -> Modal.hide ())
+                    ;  HA.type_ "button"
+                    |]
+                    [| H.text "Cancel" |]
+                |]
+            |]
+        |]
+    |]
+
+
 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"
-          |]
-      |]
+    Leaflet.marker pos
+      { title = init_name
+      ; icon = Icon.create init_icon init_color
+      ; draggable = true
+      }
   in
 
-  (* Open a modification / deletion modal on click *)
-  let () = Leaflet.on marker "click" (fun _ ->
-    Modal.show (form on_remove on_update)) in
+  (* Context menu *)
+  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 }
+      |])
+  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
 
+  let () = Leaflet.on marker "dblclick" (fun _ ->
+    Modal.show (form (on_update pos pos) init_name init_color init_icon)) in
+
   marker