zapashcanon/leaflet
1
0
Fork 0
forked from swrup/leaflet
Code Issues Pull Requests Projects Releases Wiki Activity

use gadts for layer, clean code

Browse Source
This commit is contained in:
zapashcanon 2022-04-09 22:21:22 +02:00
parent f4ab3e17ad
commit fbfb403734
Signed by: zapashcanon
GPG Key ID: 8981C3C62D1D28F1
17 changed files with 152 additions and 163 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
src/dune
View File

@ -1,15 +1,7 @@
(library
(public_name leaflet)
(modules
event
geojson_layer
global
latlng
layer
map
marker
popup
tile_layer)
(modules event global latlng layer map popup)
(private_modules global)
(libraries brr)
(js_of_ocaml
(javascript_files leaflet.js)))

4
src/event.ml
View File

@ -9,7 +9,7 @@ type _ sub =
| Move_end : [> `Basic ] sub
| Zoom_end : [> `Basic ] sub
let of_jv_t : type kind. kind sub -> Jv.t -> kind t =
let of_jv : type kind. kind sub -> Jv.t -> kind t =
fun tag e ->
match tag with Click -> Mouse e | Move_end -> Basic e | Zoom_end -> Basic e
@ -48,7 +48,7 @@ let layer_point : [ `Mouse ] t -> Jv.t = function
| Mouse e -> Jv.get e "layerPoint"
let latlng : [ `Mouse ] t -> Latlng.t = function
| Mouse e -> Jv.get e "latlng" |> Latlng.of_jv_t
| Mouse e -> Jv.get e "latlng" |> Latlng.of_jv
(** Error events *)

2
src/event.mli
View File

@ -9,7 +9,7 @@ type _ sub =
| Move_end : [> `Basic ] sub
| Zoom_end : [> `Basic ] sub
val of_jv_t : 'a sub -> Jv.t -> 'a t
val of_jv : 'a sub -> Jv.t -> 'a t
val sub_to_string : _ sub -> string

4
src/geojson_layer.ml
View File

@ -1,4 +0,0 @@
include Layer
let create ?(options = Jv.null) geojson =
of_jv_t @@ Jv.call Global.leaflet "geoJSON" [| geojson; options |]

23
src/geojson_layer.mli
View File

@ -1,23 +0,0 @@
type t
val create : ?options:Jv.t -> Jv.t -> t
val add_to : Map.t -> t -> unit
val remove : t -> unit
val remove_from : Map.t -> t -> unit
val bind_popup : Brr.El.t -> t -> unit
val unbind_popup : t -> unit
val open_popup : t -> unit
val close_popup : t -> unit
val get_popup : t -> Popup.t
val of_jv_t : Jv.t -> t
val to_jv_t : t -> Jv.t

4
src/latlng.ml
View File

@ -9,6 +9,6 @@ let lng latlng = Jv.get latlng "lng" |> Jv.to_float
let equals a b = Jv.call a "equals" [| b |] |> Jv.to_bool
let of_jv_t = Fun.id
let of_jv = Fun.id
let to_jv_t = Fun.id
let to_jv = Fun.id

4
src/latlng.mli
View File

@ -8,6 +8,6 @@ val lng : t -> float
val equals : t -> t -> bool
val of_jv_t : Jv.t -> t
val of_jv : Jv.t -> t
val to_jv_t : t -> Jv.t
val to_jv : t -> Jv.t

92
src/layer.ml
View File

@ -1,23 +1,89 @@
type t = Jv.t
type _ t =
| Basic : Jv.t -> [> `Basic ] t
| Geojson : Jv.t -> [> `Geojson ] t
| Marker : Jv.t -> [> `Marker ] t
| Tile : Jv.t -> [> `Tile ] t
let add_to map layer = ignore @@ Jv.call layer "addTo" [| Map.to_jv_t map |]
(** Basic layers *)
let remove layer = ignore @@ Jv.call layer "remove" [||]
let add_to : type kind. Map.t -> kind t -> unit =
fun map -> function
| Basic l | Geojson l | Marker l | Tile l ->
let (_ : Jv.t) = Jv.call l "addTo" [| Map.to_jv map |] in
()
let remove_from map layer =
ignore @@ Jv.call layer "removeFrom" [| Map.to_jv_t map |]
let remove : type kind. kind t -> unit = function
| Basic l | Geojson l | Marker l | Tile l ->
let (_ : Jv.t) = Jv.call l "remove" [||] in
()
let bind_popup el layer =
ignore @@ Jv.call layer "bindPopup" [| Brr.El.to_jv el |]
let remove_from : type kind. Map.t -> kind t -> unit =
fun map -> function
| Basic l | Geojson l | Marker l | Tile l ->
let (_ : Jv.t) = Jv.call l "removeFrom" [| Map.to_jv map |] in
()
let unbind_popup layer = ignore @@ Jv.call layer "unbindPopup" [||]
let bind_popup : type kind. Brr.El.t -> kind t -> unit =
fun el -> function
| Basic l | Geojson l | Marker l | Tile l ->
let (_ : Jv.t) = Jv.call l "bindPopup" [| Brr.El.to_jv el |] in
()
let open_popup layer = ignore @@ Jv.call layer "openPopup" [||]
let unbind_popup : type kind. kind t -> unit = function
| Basic l | Geojson l | Marker l | Tile l ->
let (_ : Jv.t) = Jv.call l "unbindPopup" [||] in
()
let close_popup layer = ignore @@ Jv.call layer "closePopup" [||]
let open_popup : type kind. kind t -> unit = function
| Basic l | Geojson l | Marker l | Tile l ->
let (_ : Jv.t) = Jv.call l "openPopup" [||] in
()
let get_popup layer = Popup.of_jv_t @@ Jv.call layer "getPopup" [||]
let close_popup : type kind. kind t -> unit = function
| Basic l | Geojson l | Marker l | Tile l ->
let (_ : Jv.t) = Jv.call l "closePopup" [||] in
()
let of_jv_t = Fun.id
let get_popup : type kind. kind t -> Popup.t = function
| Basic l | Geojson l | Marker l | Tile l ->
Jv.call l "getPopup" [||] |> Popup.of_jv
let to_jv_t = Fun.id
let to_jv : type kind. kind t -> Jv.t = function
| Basic l | Geojson l | Marker l | Tile l -> l
(** Geojson layers *)
let create_geojson : ?options:Jv.t -> Jv.t -> [ `Geojson ] t =
fun ?(options = Jv.null) geojson ->
let jv_t = Jv.call Global.leaflet "geoJSON" [| geojson; options |] in
Geojson jv_t
(** Marker layers *)
let create_marker : Latlng.t -> [ `Marker ] t =
fun latlng ->
let jv_t = Jv.call Global.leaflet "marker" [| Latlng.to_jv latlng |] in
Marker jv_t
(** Tile layers *)
let create_tile_osm : string option -> [ `Tile ] t =
fun url ->
(* see https://wiki.openstreetmap.org/wiki/Tile_servers *)
let url =
Option.value url
~default:"https://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png"
in
let jv_t =
Jv.call Global.leaflet "tileLayer"
[| Jv.of_string url
; Jv.obj
[| ( "attribution"
, Jv.of_string
"&copy; <a \
href=\"https://www.openstreetmap.org/copyright\">OpenStreetMap</a> \
contributors" )
|]
|]
in
Tile jv_t

38
src/layer.mli
View File

@ -1,21 +1,37 @@
type t
type _ t =
| Basic : Jv.t -> [> `Basic ] t
| Geojson : Jv.t -> [> `Geojson ] t
| Marker : Jv.t -> [> `Marker ] t
| Tile : Jv.t -> [> `Tile ] t
val add_to : Map.t -> t -> unit
(** Basic layers *)
val remove : t -> unit
val add_to : Map.t -> _ t -> unit
val remove_from : Map.t -> t -> unit
val remove : _ t -> unit
val bind_popup : Brr.El.t -> t -> unit
val remove_from : Map.t -> _ t -> unit
val unbind_popup : t -> unit
val bind_popup : Brr.El.t -> _ t -> unit
val open_popup : t -> unit
val unbind_popup : _ t -> unit
val close_popup : t -> unit
val open_popup : _ t -> unit
val get_popup : t -> Popup.t
val close_popup : _ t -> unit
val of_jv_t : Jv.t -> t
val get_popup : _ t -> Popup.t
val to_jv_t : t -> Jv.t
val to_jv : _ t -> Jv.t
(** Geojson layers *)
val create_geojson : ?options:Jv.t -> Jv.t -> [ `Geojson ] t
(** Marker layers *)
val create_marker : Latlng.t -> [ `Marker ] t
(** Tile layers *)
val create_tile_osm : string option -> [ `Tile ] t

39
src/map.ml
View File

@ -1,38 +1,43 @@
type t = Jv.t
let of_jv_t = Fun.id
let of_jv = Fun.id
let to_jv_t = Fun.id
let to_jv = Fun.id
let create ?(options = Jv.null) container_id =
Jv.call Global.leaflet "map" [| Jv.of_string container_id; options |]
let invalidate_size map = ignore @@ Jv.call map "invalidateSize" [| Jv.true' |]
let invalidate_size map =
let (_ : Jv.t) = Jv.call map "invalidateSize" [| Jv.true' |] in
()
let fit_world map = ignore @@ Jv.call map "fitWorld" [||]
let fit_world map =
let (_ : Jv.t) = Jv.call map "fitWorld" [||] in
()
let get_container map =
Jv.call (to_jv_t map) "getContainer" [||] |> Brr.El.of_jv
let get_container map = Jv.call (to_jv map) "getContainer" [||] |> Brr.El.of_jv
let set_view latlng ?zoom map =
let latlng = Latlng.to_jv_t latlng in
ignore
@@
match zoom with
| None -> Jv.call map "setView" [| latlng |]
| Some zoom -> Jv.call map "setView" [| latlng; Jv.of_int zoom |]
let set_view latlng ~zoom map =
let latlng = Latlng.to_jv latlng in
let (_ : Jv.t) =
match zoom with
| None -> Jv.call map "setView" [| latlng |]
| Some zoom -> Jv.call map "setView" [| latlng; Jv.of_int zoom |]
in
()
let as_target map = Brr.Ev.target_of_jv map
let on : type kind. kind Event.sub -> (kind Event.t -> 'b) -> t -> unit =
fun event handler map ->
let name = Event.sub_to_string event in
let handler v = handler @@ Event.of_jv_t event v in
ignore @@ Jv.call map "on" [| Jv.of_string name; Jv.repr handler |]
let handler v = handler @@ Event.of_jv event v in
let (_ : Jv.t) = Jv.call map "on" [| Jv.of_string name; Jv.repr handler |] in
()
let get_center map = Latlng.of_jv_t @@ Jv.call map "getCenter" [||]
let get_center map = Latlng.of_jv @@ Jv.call map "getCenter" [||]
let get_zoom map = Jv.call map "getZoom" [||] |> Jv.to_int
let wrapped_latlng latlng map =
Latlng.of_jv_t @@ Jv.call map "wrapLatLng" [| Latlng.to_jv_t latlng |]
Latlng.of_jv @@ Jv.call map "wrapLatLng" [| Latlng.to_jv latlng |]

6
src/map.mli
View File

@ -4,7 +4,7 @@ val create : ?options:Jv.t -> string -> t
val invalidate_size : t -> unit
val set_view : Latlng.t -> ?zoom:int -> t -> unit
val set_view : Latlng.t -> zoom:int option -> t -> unit
val fit_world : t -> unit
@ -20,6 +20,6 @@ val wrapped_latlng : Latlng.t -> t -> Latlng.t
val as_target : t -> Brr.Ev.target
val of_jv_t : Jv.t -> t
val of_jv : Jv.t -> t
val to_jv_t : t -> Jv.t
val to_jv : t -> Jv.t

4
src/marker.ml
View File

@ -1,4 +0,0 @@
include Layer
let create latlng =
of_jv_t @@ Jv.call Global.leaflet "marker" [| Latlng.to_jv_t latlng |]

23
src/marker.mli
View File

@ -1,23 +0,0 @@
type t
val create : Latlng.t -> t
val add_to : Map.t -> t -> unit
val remove : t -> unit
val remove_from : Map.t -> t -> unit
val bind_popup : Brr.El.t -> t -> unit
val unbind_popup : t -> unit
val open_popup : t -> unit
val close_popup : t -> unit
val get_popup : t -> Popup.t
val of_jv_t : Jv.t -> t
val to_jv_t : t -> Jv.t

16
src/popup.ml
View File

@ -3,13 +3,19 @@ type t = Jv.t
let popup = Jv.call Global.leaflet "popup" [||]
let set_latlng latlng =
ignore @@ Jv.call popup "setLatLng" [| Latlng.to_jv_t latlng |]
let (_ : Jv.t) = Jv.call popup "setLatLng" [| Latlng.to_jv latlng |] in
()
let set_content content =
ignore @@ Jv.call popup "setContent" [| Jv.of_string content |]
let (_ : Jv.t) = Jv.call popup "setContent" [| Jv.of_string content |] in
()
let open_on map = ignore @@ Jv.call popup "openOn" [| Map.to_jv_t map |]
let open_on map =
let (_ : Jv.t) = Jv.call popup "openOn" [| Map.to_jv map |] in
()
let close map = ignore @@ Jv.call (Map.to_jv_t map) "closePopup" [||]
let close map =
let (_ : Jv.t) = Jv.call (Map.to_jv map) "closePopup" [||] in
()
let of_jv_t = Fun.id
let of_jv = Fun.id

2
src/popup.mli
View File

@ -8,4 +8,4 @@ val open_on : Map.t -> unit
val close : Map.t -> unit
val of_jv_t : Jv.t -> t
val of_jv : Jv.t -> t

19
src/tile_layer.ml
View File

@ -1,19 +0,0 @@
include Layer
let create_osm ?tile_url () =
(* see https://wiki.openstreetmap.org/wiki/Tile_servers *)
let tile_url =
Option.fold ~some:Fun.id
~none:"https://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png" tile_url
in
of_jv_t
@@ Jv.call Global.leaflet "tileLayer"
[| Jv.of_string tile_url
; Jv.obj
[| ( "attribution"
, Jv.of_string
"&copy; <a \
href=\"https://www.openstreetmap.org/copyright\">OpenStreetMap</a> \
contributors" )
|]
|]

23
src/tile_layer.mli
View File

@ -1,23 +0,0 @@
type t
val create_osm : ?tile_url:string -> unit -> t
val add_to : Map.t -> t -> unit
val remove : t -> unit
val remove_from : Map.t -> t -> unit
val bind_popup : Brr.El.t -> t -> unit
val unbind_popup : t -> unit
val open_popup : t -> unit
val close_popup : t -> unit
val get_popup : t -> Popup.t
val of_jv_t : Jv.t -> t
val to_jv_t : t -> Jv.t