From 4ee0dfae75fda3a8b6347d55c728b50ce5c210d9 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 26 Jul 2020 18:16:59 +0200 Subject: Allow to customize icons --- src/View/Button.ml | 13 +++++ src/View/Form.ml | 56 ++++++++++++++++++++++ src/View/Form/Autocomplete.ml | 62 ++++++++++++++++++++++++ src/View/Layout.ml | 4 ++ src/View/Map.ml | 109 ++++++++++++++++++++++++++++++++---------- src/View/Map/Icon.ml | 32 +++++++++++++ src/View/Map/Marker.ml | 61 +++++++++++++++++++++++ src/View/Map/MarkerForm.ml | 0 src/View/Modal.ml | 27 +++++++++++ 9 files changed, 339 insertions(+), 25 deletions(-) create mode 100644 src/View/Button.ml create mode 100644 src/View/Form.ml create mode 100644 src/View/Form/Autocomplete.ml create mode 100644 src/View/Layout.ml create mode 100644 src/View/Map/Icon.ml create mode 100644 src/View/Map/Marker.ml delete mode 100644 src/View/Map/MarkerForm.ml create mode 100644 src/View/Modal.ml (limited to 'src/View') diff --git a/src/View/Button.ml b/src/View/Button.ml new file mode 100644 index 0000000..31fa1b0 --- /dev/null +++ b/src/View/Button.ml @@ -0,0 +1,13 @@ +let action on_click label = + H.button + [| HA.class_ "g-Button__Action" + ; HE.on_click on_click + |] + [| H.text label |] + +let danger on_click label = + H.button + [| HA.class_ "g-Button__Danger" + ; HE.on_click on_click + |] + [| H.text label |] diff --git a/src/View/Form.ml b/src/View/Form.ml new file mode 100644 index 0000000..b0319b5 --- /dev/null +++ b/src/View/Form.ml @@ -0,0 +1,56 @@ +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" |] + [| H.div + [| HA.class_ "g-Form__Label" |] + [| H.label + [| HA.for_ id |] + [| H.text label |] + |] + ; H.input + [| HA.id id + ; HE.on_input (fun e -> on_input (Element.value (Event.target e))) + ; HA.value init_value + |] + [| |] + |] + +let color_input id label init_value on_input = + H.div + [| HA.class_ "g-Form__Field" |] + [| H.div + [| HA.class_ "g-Form__Label" |] + [| H.label + [| HA.for_ id |] + [| H.text label |] + |] + ; H.input + [| HA.id id + ; HE.on_input (fun e -> on_input (Element.value (Event.target e))) + ; HA.value init_value + ; HA.type_ "color" + |] + [| |] + |] + +let textarea id label init_value on_input = + H.div + [| HA.class_ "g-Form__Field" |] + [| H.div + [| HA.class_ "g-Form__Label" |] + [| H.label + [| HA.for_ id |] + [| H.text label |] + |] + ; H.textarea + [| HA.id id + ; HA.class_ "g-Form__Textarea" + ; HE.on_input (fun e -> on_input (Element.value (Event.target e))) + |] + [| H.text init_value |] + |] diff --git a/src/View/Form/Autocomplete.ml b/src/View/Form/Autocomplete.ml new file mode 100644 index 0000000..537316d --- /dev/null +++ b/src/View/Form/Autocomplete.ml @@ -0,0 +1,62 @@ +let search s xs = + if s == "" then + [| |] + else + let results = Js.Array.filter (Js.String.includes s) xs in + if Js.Array.length results == 1 && results.(0) == s then [| |] else results + +let render_completion on_select entries = + H.div + [| HA.class_ "g-Autocomplete__Completion" |] + (entries + |> Js.Array.map (fun c -> + H.button + [| HA.class_ "g-Autocomplete__Entry" + ; HA.type_ "button" + ; HE.on_click (fun _ -> on_select c) + |] + [| H.text c |])) + +let create id label values on_input attrs = + + let completion = + H.div [| |] [| |] + in + + let update_completion target value = + let entries = search value values in + Element.mount_on completion (render_completion + (fun selected -> + let () = Element.set_value target selected in + let () = Element.remove_children completion in + on_input selected) + entries) + in + + H.div + [| HA.class_ "g-Autocomplete" |] + [| H.div + [| HA.class_ "g-Form__Label" |] + [| H.label + [| HA.for_ id |] + [| H.text label |] + |] + ; H.input + (Js.Array.concat + [| HA.id id + ; HA.class_ "g-Autocomplete__Input" + ; HA.autocomplete "off" + ; HE.on_click (fun e -> + let target = Event.target e in + let value = Element.value target in + update_completion target value) + ; HE.on_input (fun e -> + let target = Event.target e in + let value = Element.value target in + let () = update_completion target value in + on_input value) + |] + attrs) + [| |] + ; completion + |] diff --git a/src/View/Layout.ml b/src/View/Layout.ml new file mode 100644 index 0000000..98218ad --- /dev/null +++ b/src/View/Layout.ml @@ -0,0 +1,4 @@ +let section attrs content = + H.div + (Js.Array.concat [| HA.class_ "g-Layout__Section" |] attrs) + content diff --git a/src/View/Map.ml b/src/View/Map.ml index bcd0506..969a95a 100644 --- a/src/View/Map.ml +++ b/src/View/Map.ml @@ -1,28 +1,87 @@ -let render () = - let - _ = - Js.Global.setTimeout - (fun () -> - let map = Leaflet.map("g-Map__Content") in - let tileLayer = Leaflet.tileLayer "http://{s}.tile.osm.org/{z}/{x}/{y}.png" in - let () = Leaflet.addTo tileLayer map in - let () = Leaflet.setView map [| 51.505; -0.09 |] 13 in - Leaflet.on map "contextmenu" (fun (event) -> - Leaflet.addTo (Leaflet.marker (Leaflet.latLng event) { title = "Hey"; }) map)) - 0 - in +let mapView = H.div - ~attributes:[| H.className "g-Layout__Page" |] - ~children: [| - H.div - ~attributes:[| H.className "g-Layout__Header" |] - ~children:[| H.text "Map" |] - (); - H.div - ~attributes:[| H.className "g-Map" |] - ~children:[| - H.div ~attributes:[| H.id "g-Map__Content" |] () + [| HA.class_ "g-Layout__Page" |] + [| H.div + [| HA.class_ "g-Layout__Header" |] + [| H.a + [| HA.class_ "g-Layout__Home" + ; HA.href "#" + |] + [| H.text "Map" |] + |] + ; H.div + [| HA.class_ "g-Map" |] + [| H.div + [| HA.id "g-Map__Content" |] + [||] |] - (); |] - () + +let state_from_hash () = + let hash = Js.String.sliceToEnd ~from:1 (Location.hash Document.location) in + State.from_string hash + +let installMap () = + let state = ref (state_from_hash ()) in + let map = Leaflet.map "g-Map__Content" in + let title_layer = Leaflet.title_layer "http://{s}.tile.osm.org/{z}/{x}/{y}.png" in + let markers = Leaflet.feature_group [| |] in + let () = Leaflet.add_layer map markers in + let () = Leaflet.add_layer map title_layer in + + let rec reload_from_hash focus = + let update_state new_state = + let () = History.push_state "" "" ("#" ^ State.to_string new_state) () in + reload_from_hash false + in + + let on_remove pos = + update_state (State.remove !state pos) in + + let on_update previousPos pos name color icon = + update_state (State.update !state previousPos { pos = pos; name = name; color = color; icon = icon }) in + + let () = + if Js.Array.length (Leaflet.get_layers markers ()) > 0 then + Leaflet.clear_layers markers + else + () + in + let () = state := state_from_hash () in + let () = + Js.Array.forEach + (fun (m: State.marker_state) -> Leaflet.add_layer markers (Marker.create on_remove on_update m.pos m.name m.color m.icon)) + !state + in + if focus then + if Js.Array.length (Leaflet.get_layers markers ()) > 0 then + Leaflet.fit_bounds map (Leaflet.get_bounds markers ()) { padding = [| 50.; 50. |] } + else + Leaflet.setView map [| 51.505; -0.09 |] 2 + else + () + in + + (* Init markers from url *) + let () = reload_from_hash true in + + (* Reload the map if the URL changes *) + let () = Element.addEventListener 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 new_state = State.update !state pos new_marker in + let () = History.push_state "" "" ("#" ^ State.to_string new_state) () in + reload_from_hash false) + +let render () = + let _ = Js.Global.setTimeout installMap 0 in + mapView diff --git a/src/View/Map/Icon.ml b/src/View/Map/Icon.ml new file mode 100644 index 0000000..9b1f40a --- /dev/null +++ b/src/View/Map/Icon.ml @@ -0,0 +1,32 @@ +let create name color = + let c = Color.from_raw color in + let crBlack = Color.contrast_ratio { r = 0.; g = 0.; b = 0. } c in + 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" + ; popupAnchor = [| 0.; -34. |] + ; html = + H.div + [| |] + [| H.div + [| HA.class_ "marker-round" + ; HA.style ("background-color: " ^ color) + |] + [| |] + ; H.div [| HA.class_ "marker-peak-border" |] [| |] + ; H.div + [| HA.class_ "marker-peak-inner" + ; HA.style ("border-top-color: " ^ color) + |] + [| |] + ; H.div + [| HA.class_ "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 new file mode 100644 index 0000000..a96af86 --- /dev/null +++ b/src/View/Map/Marker.ml @@ -0,0 +1,61 @@ +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" + |] + |] + in + + (* Open a modification / deletion modal on click *) + let () = Leaflet.on marker "click" (fun _ -> + Modal.show (form on_remove on_update)) 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 + + marker diff --git a/src/View/Map/MarkerForm.ml b/src/View/Map/MarkerForm.ml deleted file mode 100644 index e69de29..0000000 diff --git a/src/View/Modal.ml b/src/View/Modal.ml new file mode 100644 index 0000000..9365555 --- /dev/null +++ b/src/View/Modal.ml @@ -0,0 +1,27 @@ +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