leaflet/src/layer.ml

(* BSD-2-Clause License *)

type _ t =
  | Basic : Jv.t -> [> `Basic ] t
  | Geojson : Jv.t -> [> `Geojson ] t
  | Marker : Jv.t -> [> `Marker ] t
  | Tile : Jv.t -> [> `Tile ] t
  | Vector : Jv.t -> [> `Vector ] t

type _ sub =
  | Basic : [> `Basic ] sub
  | Geojson : [> `Geojson ] sub
  | Marker : [> `Marker ] sub
  | Tile : [> `Tile ] sub
  | Vector : [> `Vector ] sub

(** Basic layers *)

let add_to : type kind. Map.t -> kind t -> unit =
 fun map -> function
  | Basic l | Geojson l | Marker l | Tile l | Vector l ->
    let (_ : Jv.t) = Jv.call l "addTo" [| Map.to_jv map |] in
    ()

let remove : type kind. kind t -> unit = function
  | Basic l | Geojson l | Marker l | Tile l | Vector l ->
    let (_ : Jv.t) = Jv.call l "remove" [||] in
    ()

let remove_from : type kind. Map.t -> kind t -> unit =
 fun map -> function
  | Basic l | Geojson l | Marker l | Tile l | Vector l ->
    let (_ : Jv.t) = Jv.call l "removeFrom" [| Map.to_jv map |] in
    ()

let bind_popup : type kind. Popup.t -> kind t -> unit =
 fun popup -> function
  | Basic layer | Geojson layer | Marker layer | Tile layer | Vector layer ->
    let (_ : Jv.t) = Jv.call layer "bindPopup" [| Popup.to_jv popup |] in
    ()

let unbind_popup : type kind. kind t -> unit = function
  | Basic l | Geojson l | Marker l | Tile l | Vector l ->
    let (_ : Jv.t) = Jv.call l "unbindPopup" [||] in
    ()

let open_popup : type kind. kind t -> unit = function
  | Basic l | Geojson l | Marker l | Tile l | Vector l ->
    let (_ : Jv.t) = Jv.call l "openPopup" [||] in
    ()

let close_popup : type kind. kind t -> unit = function
  | Basic l | Geojson l | Marker l | Tile l | Vector l ->
    let (_ : Jv.t) = Jv.call l "closePopup" [||] in
    ()

let get_popup : type kind. kind t -> Popup.t = function
  | Basic l | Geojson l | Marker l | Tile l | Vector l ->
    Jv.call l "getPopup" [||] |> Popup.of_jv

let to_jv : type kind. kind t -> Jv.t = function
  | Basic l | Geojson l | Marker l | Tile l | Vector l -> l

let of_jv : type kind. kind sub -> Jv.t -> kind t =
 fun tag l ->
  match tag with
  | Basic -> Basic l
  | Geojson -> Geojson l
  | Marker -> Marker l
  | Tile -> Tile l
  | Vector -> Vector l

let on : type kind. kind Event.sub -> (kind Event.t -> 'b) -> 'c t -> unit =
 fun event handler layer ->
  let name = Event.sub_to_string event in
  let handler v = handler @@ Event.of_jv event v in
  let (_ : Jv.t) =
    Jv.call (to_jv layer) "on" [| Jv.of_string name; Jv.repr handler |]
  in
  ()

(** Geojson layers *)

type geojson_opt =
  | Point_to_layer of (Jv.t -> Latlng.t -> [ `Marker ] t)
  | Style of (Jv.t -> unit)
  | On_each_feature of (Jv.t -> [ `Geojson ] t -> unit)
  | Filter of (Jv.t -> bool)
  | Coords_to_latlng of (Jv.t -> Latlng.t)
  | Markers_inherit_options of bool

let geojson_opt_to_string = function
  | Point_to_layer _ -> "pointToLayer"
  | Style _ -> "style"
  | On_each_feature _ -> "onEachFeature"
  | Filter _ -> "filter"
  | Coords_to_latlng _ -> "coordsToLatLng"
  | Markers_inherit_options _ -> "markersInheritOptions"

let geojson_opt_to_jv = function
  | Markers_inherit_options b -> Jv.of_bool b
  | Point_to_layer f ->
    (* the marker returned by `pointToLayer` is used internally by leaflet so we neet to unwrap it to a Jv.t *)
    Jv.repr (fun geojsonpoint latlng -> to_jv @@ f geojsonpoint latlng)
  | Style f -> Jv.repr f
  | On_each_feature f ->
    (* we need to wrap the Jv.t *)
    let f feature jv = jv |> of_jv Geojson |> f feature in
    Jv.repr f
  | Filter f -> Jv.repr f
  | Coords_to_latlng f -> Jv.repr f

let create_geojson : Jv.t -> geojson_opt array -> [ `Geojson ] t =
 fun geojson options ->
  let l =
    Array.map (fun o -> (geojson_opt_to_string o, geojson_opt_to_jv o)) options
  in
  let jv_t = Jv.call Global.leaflet "geoJSON" [| geojson; Jv.obj l |] in
  Geojson jv_t

(** Tile layers *)

type tile_layer_opt =
  | Min_zoom of int
  | Max_zoom of int
  | Subdomains of string array
  | Error_tile_url of string
  | Zoom_offset of int
  | Tms of bool
  | Zoom_reverse of bool
  | Detect_retina of bool
  | (* TODO allow string for those two
       "Whether the crossOrigin attribute will be added to the tiles. If a String is provided, all tiles will have their crossOrigin attribute set to the String provided. This is needed if you want to access tile pixel data. Refer to CORS Settings for valid String values."
    *)
    Cross_origin of bool
  | Referrer_policy of bool
  | (* GridLayer options *)
    Tile_size of Point.t
  | Opacity of float
  | Update_when_idle of bool
  | Update_when_zooming of bool
  | Update_interval of int
  | Z_index of int
  | Bounds of (* LatLngBounds *) Latlng.t * Latlng.t
  | Max_native_zoom of int
  | Min_native_zoom of int
  | No_wrap of bool
  | Pane of string
  | Class_name of string
  | Keep_buffer of int

let tile_layer_opt_to_string = function
  | Min_zoom _ -> "minZoom"
  | Max_zoom _ -> "maxZoom"
  | Subdomains _ -> "subdomains"
  | Error_tile_url _ -> "errorTileUrl"
  | Zoom_offset _ -> "zoomOffset"
  | Tms _ -> "tms"
  | Zoom_reverse _ -> "zoomReverse"
  | Detect_retina _ -> "detectRetina"
  | Cross_origin _ -> "crossOrigin"
  | Referrer_policy _ -> "referrerPolicy"
  | Tile_size _ -> "tileSize"
  | Opacity _ -> "opacity"
  | Update_when_idle _ -> "updateWhenIdle"
  | Update_when_zooming _ -> "updateWhenZooming"
  | Update_interval _ -> "updateInterval"
  | Z_index _ -> "zIndex"
  | Bounds _ -> "bounds"
  | Max_native_zoom _ -> "maxNativeZoom"
  | Min_native_zoom _ -> "minNativeZoom"
  | No_wrap _ -> "noWrap"
  | Pane _ -> "pane"
  | Class_name _ -> "className"
  | Keep_buffer _ -> "keepBuffer"

let tile_layer_opt_to_jv = function
  | Min_zoom o
  | Max_zoom o
  | Zoom_offset o
  | Update_interval o
  | Z_index o
  | Keep_buffer o
  | Min_native_zoom o
  | Max_native_zoom o ->
    Jv.of_int o
  | Tms o
  | Zoom_reverse o
  | Detect_retina o
  | Cross_origin o
  | Referrer_policy o
  | Update_when_idle o
  | Update_when_zooming o
  | No_wrap o ->
    Jv.of_bool o
  | Error_tile_url o | Pane o | Class_name o -> Jv.of_string o
  | Subdomains o -> Jv.of_array Jv.of_string o
  | Opacity o -> Jv.of_float o
  | Tile_size o -> Point.to_jv o
  | Bounds (a, b) ->
    (* create the actual LatlngBounds from the pair *)
    Jv.call Global.leaflet "latLngBounds" [| Latlng.to_jv a; Latlng.to_jv b |]

let create_tile :
    string -> attribution:string -> tile_layer_opt array -> [ `Tile ] t =
 fun url ~attribution options ->
  let arr =
    Array.append
      [| ("attribution", Jv.of_string attribution) |]
      (Array.map
         (fun o -> (tile_layer_opt_to_string o, tile_layer_opt_to_jv o))
         options )
  in
  let jv_t =
    Jv.call Global.leaflet "tileLayer" [| Jv.of_string url; Jv.obj arr |]
  in
  Tile jv_t

let create_tile_osm : tile_layer_opt array -> [ `Tile ] t =
 fun options ->
  let url = "https://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png" in
  let attribution =
    "&copy; <a \
     href=\"https://www.openstreetmap.org/copyright\">OpenStreetMap</a> \
     contributors"
  in
  create_tile url ~attribution options

(* Vector Layers *)

(* TODO add options *)

let create_polyline : Latlng.t array -> [ `Vector ] t =
 fun l ->
  let l = Jv.of_array Latlng.to_jv l in
  let jv_t = Jv.call Global.leaflet "polyline" [| l |] in
  Vector jv_t

let create_circle_marker : Latlng.t -> float -> [ `Vector ] t =
 fun center radius ->
  let center = Latlng.to_jv center in
  let arr = [| ("radius", Jv.of_float radius) |] in
  let jv_t = Jv.call Global.leaflet "circleMarker" [| center; Jv.obj arr |] in
  Vector jv_t