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/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 ------------ 7 files changed, 100 insertions(+), 109 deletions(-) delete mode 100644 src/View/Modal.ml (limited to 'src/View') 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