From 081e6aae57719c15bdbc5e973ca7ddba9506a4bb Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 8 Aug 2020 12:49:03 +0200 Subject: Show context menu to add, modify and delete markers --- src/Lib/ContextMenu.ml | 40 ++++++++++++++++++++++++++++++++++++++++ src/Lib/Dom/Document.ml | 15 +++++++++------ src/Lib/Dom/Element.ml | 33 +++++++++++++-------------------- src/Lib/Dom/Event.ml | 12 ++++++++++-- src/Lib/Dom/H.ml | 12 ++++++------ src/Lib/Leaflet.ml | 3 +++ src/Lib/Modal.ml | 25 +++++++++++++++++++++++++ 7 files changed, 106 insertions(+), 34 deletions(-) create mode 100644 src/Lib/ContextMenu.ml create mode 100644 src/Lib/Modal.ml (limited to 'src/Lib') 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 -- cgit v1.2.3