aboutsummaryrefslogtreecommitdiff
path: root/src/View
diff options
context:
space:
mode:
Diffstat (limited to 'src/View')
-rw-r--r--src/View/Button.ml18
-rw-r--r--src/View/Form.ml5
-rw-r--r--src/View/Layout.ml5
-rw-r--r--src/View/Map.ml31
-rw-r--r--src/View/Map/Icon.ml12
-rw-r--r--src/View/Map/Marker.ml111
-rw-r--r--src/View/Modal.ml27
7 files changed, 100 insertions, 109 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-18 13:41:42 +0000