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 --- public/main.css | 68 ++++++++++++++++++++++------- src/Color.ml | 6 +-- 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 +++++++++++ src/Main.ml | 4 +- src/View/Button.ml | 18 +++----- src/View/Form.ml | 5 --- src/View/Layout.ml | 5 +++ src/View/Map.ml | 31 +++++++++----- src/View/Map/Icon.ml | 12 +++--- src/View/Map/Marker.ml | 111 ++++++++++++++++++++++++++---------------------- src/View/Modal.ml | 27 ------------ 17 files changed, 263 insertions(+), 164 deletions(-) create mode 100644 src/Lib/ContextMenu.ml create mode 100644 src/Lib/Modal.ml delete mode 100644 src/View/Modal.ml diff --git a/public/main.css b/public/main.css index 3edf5cf..c57ae2f 100644 --- a/public/main.css +++ b/public/main.css @@ -38,9 +38,13 @@ body { margin-bottom: 2rem; } +.g-Layout__Line > *:not(:last-child) { + margin-right: 2rem; +} + /* Modal */ -.g-Modal { +#g-Modal { z-index: 1000; position: absolute; top: 0; @@ -74,14 +78,46 @@ body { top: 2rem; right: 2rem; cursor: pointer; + border: none; + background-color: transparent; + font-size: 200%; } -/* Form */ +/* Context menu */ + +:root { + --context-menu-border-radius: 2px; +} + +#g-ContextMenu { + z-index: 1000; + position: absolute; + background-color: white; + border-radius: var(--context-menu-border-radius); + border: 1px solid #333333; +} + +.g-ContextMenu__Entry:first-child { + border-top-left-radius: var(--context-menu-border-radius); + border-top-right-radius: var(--context-menu-border-radius); +} -.g-Form__Section { - margin: 0 0 2rem; +.g-ContextMenu__Entry:last-child { + border-bottom-left-radius: var(--context-menu-border-radius); + border-bottom-right-radius: var(--context-menu-border-radius); } +.g-ContextMenu__Entry { + padding: 0.5rem 1rem; +} + +.g-ContextMenu__Entry:hover { + background-color: #DDDDDD; + cursor: pointer; +} + +/* Form */ + .g-Form__Field { margin-bottom: 1rem; } @@ -144,8 +180,8 @@ body { cursor: pointer; } -.g-Button__Danger { - background-color: brown; +.g-Button__Cancel { + background-color: gray; color: white; padding: 0.5rem 1rem; border-radius: 0.2rem; @@ -167,16 +203,11 @@ body { #g-Map__Content { width: 100%; height: 100%; - cursor: pointer; + cursor: default; } /* Marker icon */ -.marker-box { - background-color: transparent; - border-color: transparent; -} - :root { --marker-box-size: 12px; --marker-width: 25px; @@ -186,7 +217,11 @@ body { --marker-icon-size: 14px; } -.marker-round { +.g-Marker { + cursor: move; +} + +.g-Marker__Round { position: absolute; bottom: calc(var(--marker-box-size) / 2 + var(--marker-peak-height) - var(--marker-width) * 15 / 40); left: calc((var(--marker-width) - var(--marker-box-size)) / -2); @@ -195,9 +230,10 @@ body { height: var(--marker-width); border-radius: 50%; border: var(--marker-border-width) solid var(--marker-border-color); + cursor: move; } -.marker-icon { +.g-Marker__Icon { position: absolute; bottom: calc(var(--marker-box-size) / 2 + var(--marker-peak-height) - var(--marker-width) * 15 / 40); left: calc((var(--marker-width) - var(--marker-box-size)) / -2); @@ -210,7 +246,7 @@ body { height: var(--marker-width); } -.marker-peak-inner { +.g-Marker__PeakInner { position: absolute; bottom: calc(var(--marker-box-size) / 2 + var(--marker-border-width)); left: calc((var(--marker-width) - var(--marker-box-size)) / -2 + var(--marker-border-width)); @@ -224,7 +260,7 @@ body { border-top-style: solid; } -.marker-peak-border { +.g-Marker__PeakBorder { position: absolute; bottom: calc(var(--marker-box-size) / 2); left: calc((var(--marker-width) - var(--marker-box-size)) / -2); 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/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 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 diff --git a/src/View/Modal.ml b/src/View/Modal.ml deleted file mode 100644 index 9365555..0000000 --- a/src/View/Modal.ml +++ /dev/null @@ -1,27 +0,0 @@ -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 -- cgit v1.2.3