From 225068497c5fd41da12030a6bbf58a0fc9c294d0 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 9 Aug 2020 14:44:02 +0200 Subject: Import from CSV --- public/main.css | 12 +++++ src/Lib/CSV.ml | 76 +++++++++++++++++++++++++++++ src/Lib/Dom/Element.ml | 3 ++ src/Lib/Dom/HE.ml | 2 + src/Lib/File.ml | 9 ++++ src/Lib/Leaflet.ml | 6 ++- src/Lib/Option.ml | 9 ++++ src/State.ml | 64 ++++++++++++++++++------- src/View/Map.ml | 128 ++++++++++++++++++++++++++++++------------------- 9 files changed, 241 insertions(+), 68 deletions(-) create mode 100644 src/Lib/CSV.ml create mode 100644 src/Lib/Option.ml diff --git a/public/main.css b/public/main.css index fdedc4c..dfd5c1b 100644 --- a/public/main.css +++ b/public/main.css @@ -50,6 +50,18 @@ body { margin-right: 1.5rem; } +/* Header */ + +#g-Header__ImportInput { + display: none; +} + +.g-Header__ImportLabel { + cursor: pointer; + font-size: 50%; + text-decoration: underline; +} + /* Modal */ :root { 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 -- cgit v1.2.3