aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Lib/CSV.ml76
-rw-r--r--src/Lib/Dom/Element.ml3
-rw-r--r--src/Lib/Dom/HE.ml2
-rw-r--r--src/Lib/File.ml9
-rw-r--r--src/Lib/Leaflet.ml6
-rw-r--r--src/Lib/Option.ml9
-rw-r--r--src/State.ml64
-rw-r--r--src/View/Map.ml128
8 files changed, 229 insertions, 68 deletions
diff --git a/src/Lib/CSV.ml b/src/Lib/CSV.ml
new file mode 100644
index 0000000..f0366f7
--- /dev/null
+++ b/src/Lib/CSV.ml
@@ -0,0 +1,76 @@
+let to_string lines =
+ let
+ cell_to_string cell =
+ if Js.String.includes "\"" cell then
+ "\"" ^ (Js.String.replaceByRe [%re "/\"/g"] "\"\"" cell) ^ "\""
+ else
+ cell
+ in let
+ line_to_string line =
+ line
+ |> Js.Array.map cell_to_string
+ |> Js.Array.joinWith ","
+ in lines
+ |> Js.Array.map line_to_string
+ |> Js.Array.joinWith "\n"
+
+let parse str =
+ let lines = [| |] in
+ let current_line = ref [| |] in
+ let current_cell = ref "" in
+ let in_quote = ref false in
+ let i = ref 0 in
+ let l = Js.String.length str in
+ let () = while !i < l do
+ let cc = Js.String.get str !i in
+ let nc = Js.String.get str (!i + 1) in
+ let () =
+ if !in_quote && cc == "\"" && nc == "\"" then
+ let () = current_cell := !current_cell ^ cc in
+ i := !i + 1
+ else if cc == "\"" then
+ in_quote := not !in_quote
+ else if not !in_quote && cc == "," then
+ let _ = Js.Array.push !current_cell !current_line in
+ current_cell := ""
+ else if not !in_quote && ((cc == "\r" && nc == "\n") || cc == "\n" || cc == "\r") then
+ let _ = Js.Array.push !current_cell !current_line in
+ let _ = Js.Array.push !current_line lines in
+ let _ = current_line := [| |] in
+ current_cell := ""
+ else
+ current_cell := !current_cell ^ cc
+ in
+ i := !i + 1
+ done
+ in
+ let _ =
+ if Js.String.length !current_cell > 0 then
+ let _ = Js.Array.push !current_cell !current_line in ()
+ else
+ ()
+ in
+ let _ =
+ if Js.Array.length !current_line > 0 then
+ let _ = Js.Array.push !current_line lines in ()
+ else
+ ()
+ in
+ lines
+
+let to_dicts lines =
+ let res = [| |] in
+ let () =
+ if Js.Array.length lines > 0 then
+ let header = Js.Array.unsafe_get lines 0 in
+ for i = 1 to Js.Array.length lines - 1 do
+ let line = Js.Array.unsafe_get lines i in
+ let dict = Js.Dict.empty() in
+ let () =
+ Js.Array.forEachi
+ (fun key j -> Js.Dict.set dict key (Js.Array.unsafe_get line j))
+ header
+ in
+ ignore (Js.Array.push dict res)
+ done
+ in res
diff --git a/src/Lib/Dom/Element.ml b/src/Lib/Dom/Element.ml
index 90c0321..e370cf5 100644
--- a/src/Lib/Dom/Element.ml
+++ b/src/Lib/Dom/Element.ml
@@ -43,3 +43,6 @@ let rec remove_children element =
let mount_on base element =
let () = remove_children base in
append_child base element
+
+external files : Dom.element -> string Js.Array.t = "files"
+ [@@bs.get]
diff --git a/src/Lib/Dom/HE.ml b/src/Lib/Dom/HE.ml
index c9aac16..6e658ce 100644
--- a/src/Lib/Dom/HE.ml
+++ b/src/Lib/Dom/HE.ml
@@ -7,3 +7,5 @@ let on_input f = H.EventAttr ("input", f)
let on_submit f = H.EventAttr ("submit", f)
let on_blur f = H.EventAttr ("blur", f)
+
+let on_change f = H.EventAttr ("change", f)
diff --git a/src/Lib/File.ml b/src/Lib/File.ml
index 0089001..d3597e7 100644
--- a/src/Lib/File.ml
+++ b/src/Lib/File.ml
@@ -10,3 +10,12 @@ let download filename content =
let () = Element.append_child Document.body a in
let () = Element.click a in
Element.remove_child Document.body a
+
+external reader : unit -> Dom.element = "FileReader"
+ [@@bs.new]
+
+external read_as_text : Dom.element -> string -> unit = "readAsText"
+ [@@bs.send]
+
+external result : Dom.element -> string = "result"
+ [@@bs.get]
diff --git a/src/Lib/Leaflet.ml b/src/Lib/Leaflet.ml
index 0cc7976..282b5b0 100644
--- a/src/Lib/Leaflet.ml
+++ b/src/Lib/Leaflet.ml
@@ -1,6 +1,10 @@
type layer
-external map : string -> layer = "map"
+type map_options =
+ { attributionControl : bool
+ }
+
+external map : string -> map_options -> layer = "map"
[@@bs.val] [@@bs.scope "L"]
external setView : layer -> float array -> int -> unit = "setView"
diff --git a/src/Lib/Option.ml b/src/Lib/Option.ml
new file mode 100644
index 0000000..1158b96
--- /dev/null
+++ b/src/Lib/Option.ml
@@ -0,0 +1,9 @@
+let withDefault default opt =
+ match opt with
+ | Some v -> v
+ | None -> default
+
+let map f opt =
+ match opt with
+ | Some v -> Some (f v)
+ | None -> None
diff --git a/src/State.ml b/src/State.ml
index 4c6cedb..c1cb99d 100644
--- a/src/State.ml
+++ b/src/State.ml
@@ -60,25 +60,10 @@ let from_url_string str =
(Js.Array.from (Js.String.castToArrayLike ((String.decode str) ^ sep)))
in res
-(* CSV Serialization *)
-
-let to_csv_line marker =
- [| Js.Float.toString marker.pos.lat
- ; Js.Float.toString marker.pos.lng
- ; marker.name
- ; marker.color
- ; marker.icon
- |]
- |> Js.Array.joinWith ","
-
-let to_csv_string state =
- state
- |> Js.Array.map to_csv_line
- |> Fun.flip Js.Array.concat [| "lat,lng,name,color,icon" |]
- |> Js.Array.joinWith "\n"
-
(* Colors *)
+let default_color = "#3f92cf"
+
let colors =
Js.Array.reduce
(fun colors marker ->
@@ -87,3 +72,48 @@ let colors =
else
colors)
[| |]
+
+(* CSV Serialization *)
+
+let lat_key = "lat"
+let lng_key = "lng"
+let name_key = "name"
+let color_key = "color"
+let icon_key = "icon"
+
+let to_csv_string state =
+ let to_csv_line marker =
+ [| Js.Float.toString marker.pos.lat
+ ; Js.Float.toString marker.pos.lng
+ ; marker.name
+ ; marker.color
+ ; marker.icon
+ |]
+ in let
+ header =
+ [| lat_key; lng_key; name_key; color_key; icon_key |]
+ in
+ state
+ |> Js.Array.map to_csv_line
+ |> Fun.flip Js.Array.concat [| header |]
+ |> CSV.to_string
+
+let from_dicts dicts =
+ Js.Array.map
+ (fun dict ->
+ (* let get key default = Js.Dict.get dict key |> Option.withDefault default in *)
+ { pos =
+ { lat =
+ Js.Dict.get dict lat_key
+ |> Option.map Js.Float.fromString
+ |> Option.withDefault 0.0
+ ; lng =
+ Js.Dict.get dict lng_key
+ |> Option.map Js.Float.fromString
+ |> Option.withDefault 0.0
+ }
+ ; name = Js.Dict.get dict name_key |> Option.withDefault ""
+ ; color = Js.Dict.get dict color_key |> Option.withDefault default_color
+ ; icon = Js.Dict.get dict icon_key |> Option.withDefault ""
+ })
+ dicts
diff --git a/src/View/Map.ml b/src/View/Map.ml
index 8f74b76..c85a791 100644
--- a/src/View/Map.ml
+++ b/src/View/Map.ml
@@ -1,4 +1,41 @@
-let mapView state =
+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
@@ -8,9 +45,36 @@ let mapView state =
; HA.href "#"
|]
[| H.text "Map" |]
- ; Button.text
- [| HE.on_click (fun _ -> File.download "map.csv" (State.to_csv_string !state)) |]
- [| H.text "Export" |]
+ ; Layout.line
+ [| |]
+ [| 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-Header__ImportLabel"
+ |]
+ [| 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" |]
@@ -20,64 +84,26 @@ let mapView state =
|]
|]
-let state_from_hash () =
- let hash = Js.String.sliceToEnd ~from:1 (Location.hash Document.location) in
- State.from_url_string hash
-
-let installMap state =
- let map = Leaflet.map "g-Map__Content" in
+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 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_url_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 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
- ()
- in
-
(* Init markers from url *)
- let () = reload_from_hash true in
+ 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 true)
+ 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 false
+ reload_from_hash state map markers false
in
(* Context menu *)
@@ -99,5 +125,7 @@ let installMap state =
let render () =
let state = ref (state_from_hash ()) in
- let _ = Js.Global.setTimeout (fun _ -> installMap state) 0 in
- mapView state
+ 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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 17:12:04 +0000