Show context menu to add, modify and delete markers

7 files changed, 106 insertions, 34 deletions

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/Lib/Modal.ml b/src/Lib/Modal.ml
new file mode 100644
index 0000000..3fa0550
--- /dev/null
+++ b/src/Lib/Modal.ml
@@ -0,0 +1,25 @@
+let hide () =
+  let modal = Document.query_selector_unsafe "#g-Modal" in
+  Element.remove_child Document.body modal
+
+let show content =
+  let view =
+    H.div
+      [| HA.id "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.div [| HA.class_ "fa fa-close" |] [| |] |]
+          ;  content
+          |]
+      |]
+  in
+  Element.append_child Document.body view