aboutsummaryrefslogtreecommitdiff
path: root/src/View
diff options
context:
space:
mode:
Diffstat (limited to 'src/View')
-rw-r--r--src/View/Button.ml19
-rw-r--r--src/View/Form.ml65
-rw-r--r--src/View/Form/Autocomplete.ml80
-rw-r--r--src/View/Layout.ml9
-rw-r--r--src/View/Map.ml131
-rw-r--r--src/View/Map/Icon.ml32
-rw-r--r--src/View/Map/Marker.ml105
7 files changed, 0 insertions, 441 deletions
diff --git a/src/View/Button.ml b/src/View/Button.ml
deleted file mode 100644
index b4641d2..0000000
--- a/src/View/Button.ml
+++ /dev/null
@@ -1,19 +0,0 @@
-let raw attrs content =
- H.button
- (HA.concat [| HA.class_ "g-Button__Raw" |] attrs)
- content
-
-let text attrs content =
- H.button
- (HA.concat [| HA.class_ "g-Button__Text" |] attrs)
- content
-
-let action attrs content =
- H.button
- (HA.concat [| HA.class_ "g-Button__Action" |] attrs)
- content
-
-let cancel attrs content =
- H.button
- (HA.concat [| HA.class_ "g-Button__Cancel" |] attrs)
- content
diff --git a/src/View/Form.ml b/src/View/Form.ml
deleted file mode 100644
index cec49d6..0000000
--- a/src/View/Form.ml
+++ /dev/null
@@ -1,65 +0,0 @@
-let input id label attrs =
- 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.concat attrs [| HA.id id |])
- [| |]
- |]
-
-let color_input default_colors id label init_value on_input =
- let
- input =
- H.input
- [| HA.id id
- ; HE.on_input (fun e -> on_input (Element.value (Event.target e)))
- ; HA.value init_value
- ; HA.type_ "color"
- |]
- [| |]
- in
- H.div
- [| HA.class_ "g-Form__Field" |]
- [| H.div
- [| HA.class_ "g-Form__Label" |]
- [| H.label
- [| HA.for_ id |]
- [| H.text label |]
- |]
- ; Layout.line
- [| |]
- (default_colors
- |> Js.Array.map (fun color ->
- Button.raw
- [| HA.class_ "g-Form__DefaultColor"
- ; HA.style ("background-color: " ^ color)
- ; HE.on_click (fun _ ->
- let () = Element.set_value input color in
- on_input color)
- ; HA.type_ "button"
- |]
- [| |])
- |> Fun.flip Js.Array.concat [| input |])
- |]
-
-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
deleted file mode 100644
index 98e4b43..0000000
--- a/src/View/Form/Autocomplete.ml
+++ /dev/null
@@ -1,80 +0,0 @@
-let search s xs =
- Js.Array.filter (Js.String.includes s) xs
-
-let render_completion render_entry on_select entries =
- H.div
- [| HA.class_ "g-Autocomplete__Completion" |]
- (entries
- |> Js.Array.map (fun c ->
- Button.raw
- [| HA.class_ "g-Autocomplete__Entry"
- ; HA.type_ "button"
- ; HE.on_click (fun e ->
- let () = Event.stop_propagation e in
- let () = Event.prevent_default e in
- on_select c)
- |]
- (render_entry c)))
-
-let create attrs id values render_entry on_input =
-
- let completion =
- H.div [| |] [| |]
- in
-
- let update_completion target value =
- let entries = search value values in
- Element.mount_on completion (render_completion
- render_entry
- (fun selected ->
- let () = Element.set_value target selected in
- let () = Element.remove_children completion in
- on_input selected)
- entries)
- in
-
- let hide_completion () =
- Element.mount_on completion (H.text "")
- in
-
- let
- input =
- H.input
- (HA.concat
- attrs
- [| HA.id id
- ; HA.class_ "g-Autocomplete__Input"
- ; HA.autocomplete "off"
- ; HE.on_focus (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)
- |])
- [| |]
- in
-
- let () =
- Element.add_event_listener input "blur" (fun e ->
- if Js.isNullable (Event.related_target e) then
- hide_completion ())
- in
-
- H.div
- [| HA.class_ "g-Autocomplete" |]
- [| input
- ; completion
- ; Button.raw
- [| HA.class_ "g-Autocomplete__Clear fa fa-close"
- ; HA.type_ "button"
- ; HE.on_click (fun _ ->
- let () = on_input "" in
- let () = Element.set_value input "" in
- Element.focus input)
- |]
- [| |]
- |]
diff --git a/src/View/Layout.ml b/src/View/Layout.ml
deleted file mode 100644
index db1e234..0000000
--- a/src/View/Layout.ml
+++ /dev/null
@@ -1,9 +0,0 @@
-let section attrs content =
- H.div
- (HA.concat attrs [| HA.class_ "g-Layout__Section" |])
- content
-
-let line attrs content =
- H.div
- (HA.concat attrs [| HA.class_ "g-Layout__Line" |])
- content
diff --git a/src/View/Map.ml b/src/View/Map.ml
deleted file mode 100644
index 6e2611e..0000000
--- a/src/View/Map.ml
+++ /dev/null
@@ -1,131 +0,0 @@
-let state_from_hash () =
- let hash = Js.String.sliceToEnd ~from:1 (Location.hash Document.location) in
- State.from_url_string hash
-
-let rec reload_from_hash state map markers focus =
- let update_state new_state =
- let () = History.push_state "" "" ("#" ^ State.to_url_string new_state) () in
- reload_from_hash state map markers 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 colors = State.colors !state in
- let () =
- Js.Array.forEach
- (fun (m: State.marker_state) -> Leaflet.add_layer markers (Marker.create on_remove on_update colors 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
- ()
-
-let mapView state map markers =
- H.div
- [| HA.class_ "g-Layout__Page" |]
- [| H.div
- [| HA.class_ "g-Layout__Header" |]
- [| H.a
- [| HA.class_ "g-Layout__Home"
- ; HA.href "#"
- |]
- [| H.text "Map" |]
- ; Layout.line
- [| HA.class_ "g-Layout__HeaderImportExport" |]
- [| H.input
- [| HA.id "g-Header__ImportInput"
- ; HA.type_ "file"
- ; HE.on_change (fun e ->
- match !map with
- | Some map ->
- let reader = File.reader () in
- let () = Element.add_event_listener reader "load" (fun _ ->
- let str = File.result reader in
- let new_state = State.from_dicts (CSV.to_dicts (CSV.parse str)) in
- let () = History.push_state "" "" ("#" ^ State.to_url_string new_state) () in
- reload_from_hash state map markers true)
- in
- File.read_as_text reader (
- Js.Array.unsafe_get (Element.files (Event.target e)) 0)
- | _ ->
- ())
- |]
- [| |]
- ; H.label
- [| HA.for_ "g-Header__ImportInput"
- ; HA.class_ "g-Button__Text"
- |]
- [| H.text "Import" |]
- ; Button.text
- [| HE.on_click (fun _ -> File.download "map.csv" (State.to_csv_string !state)) |]
- [| H.text "Export" |]
- |]
- |]
- ; H.div
- [| HA.class_ "g-Map" |]
- [| H.div
- [| HA.id "g-Map__Content" |]
- [||]
- |]
- |]
-
-let install_map state map_ref markers =
- let map = Leaflet.map "g-Map__Content" { attributionControl = false } in
- let () = map_ref := Some map in
- let title_layer = Leaflet.title_layer "http://{s}.tile.osm.org/{z}/{x}/{y}.png" in
- let () = Leaflet.add_layer map markers in
- let () = Leaflet.add_layer map title_layer in
-
- (* Init markers from url *)
- let () = reload_from_hash state map markers true in
-
- (* Reload the map if the URL changes *)
- let () = Element.add_event_listener Window.window "popstate" (fun _ ->
- reload_from_hash state map markers true)
- 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_url_string new_state) () in
- reload_from_hash state map markers 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
- let colors = State.colors !state in
- Modal.show (Marker.form (add_marker pos) colors marker.name marker.color marker.icon))
- }
- |])
-
-let render () =
- let state = ref (state_from_hash ()) in
- let map = ref None in
- let markers = Leaflet.feature_group [| |] in
- let _ = Js.Global.setTimeout (fun _ -> install_map state map markers) 0 in
- mapView state map markers
diff --git a/src/View/Map/Icon.ml b/src/View/Map/Icon.ml
deleted file mode 100644
index 8737f43..0000000
--- a/src/View/Map/Icon.ml
+++ /dev/null
@@ -1,32 +0,0 @@
-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 = ""
- ; popupAnchor = [| 0.; -34. |]
- ; html =
- H.div
- [| HA.class_ "g-Marker" |]
- [| H.div
- [| HA.class_ "g-Marker__Round"
- ; HA.style ("background-color: " ^ color)
- |]
- [| |]
- ; H.div [| HA.class_ "g-Marker__PeakBorder" |] [| |]
- ; H.div
- [| HA.class_ "g-Marker__PeakInner"
- ; HA.style ("border-top-color: " ^ color)
- |]
- [| |]
- ; H.div
- [| 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
deleted file mode 100644
index 1c0c0d6..0000000
--- a/src/View/Map/Marker.ml
+++ /dev/null
@@ -1,105 +0,0 @@
-let form on_validate colors 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"
- [| HE.on_input (fun e -> name := (Element.value (Event.target e)))
- ; HA.value init_name
- |]
- ; Form.color_input colors "g-MarkerForm__Color" "Color" init_color (fun newColor -> color := newColor)
- ; H.div
- [| HA.class_ "g-Form__Field" |]
- [| H.div
- [| HA.class_ "g-Form__Label" |]
- [| H.label
- [| HA.for_ "g-MarkerForm__IconInput" |]
- [| H.text "Icon" |]
- |]
- ; let dom_icon = H.div [| HA.class_ ("fa fa-" ^ !icon) |] [| |] in
- Layout.line
- [| HA.class_ "g-MarkerForm__AutocompleteAndIcon" |]
- [| Autocomplete.create
- [| HA.value init_icon
- ; HA.class_ "g-MarkerForm__Autocomplete"
- |]
- "g-MarkerForm__IconInput"
- FontAwesome.icons
- (fun icon ->
- [| H.div
- [| HA.class_ ("g-MarkerForm__IconEntry fa fa-" ^ icon) |]
- [| |]
- ; H.text icon
- |])
- (fun newIcon ->
- let () = icon := newIcon in
- Element.set_class_name dom_icon ("fa fa-" ^ newIcon))
- ; H.div [| HA.class_ "g-MarkerForm__Icon" |] [| dom_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 colors 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
-
- (* 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) colors 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) colors init_name init_color init_icon)) in
-
- marker
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-10 08:09:21 +0000