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

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

(** Basic layers *)

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 : type kind. kind t -> unit = function
  | Basic l | Geojson l | Marker l | Tile 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 ->
    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 ->
    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 ->
    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 ->
    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 ->
    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 ->
    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 -> 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

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 list -> [ `Geojson ] t =
 fun geojson options ->
  let l =
    Array.of_list
    @@ List.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

(** Marker layers *)

type marker_opt =
  | Icon of Icon.t
  | Keyboard of bool
  | Title of string
  | Alt of string
  | Z_index_offset of int
  | Opacity of float
  | Rise_on_hover of bool
  | Rise_offset of int
  | Pane of string
  | Shadow_pane of string
  | Bubbling_mouse_events of bool
  | Auto_pan_on_focus of bool

let marker_opt_to_string : marker_opt -> string = function
  | Icon _ -> "icon"
  | Keyboard _ -> "keyboard"
  | Title _ -> "title"
  | Alt _ -> "alt"
  | Z_index_offset _ -> "zIndexOffset"
  | Opacity _ -> "opacity"
  | Rise_on_hover _ -> "riseOnHover"
  | Rise_offset _ -> "riseOffset"
  | Pane _ -> "pane"
  | Shadow_pane _ -> "shadowPane"
  | Bubbling_mouse_events _ -> "bubblingMouseEvents"
  | Auto_pan_on_focus _ -> "autoPanOnFocus"

let marker_opt_to_jv = function
  | Icon icon -> Icon.to_jv icon
  | Keyboard b | Rise_on_hover b | Bubbling_mouse_events b | Auto_pan_on_focus b
    ->
    Jv.of_bool b
  | Title s | Alt s | Pane s | Shadow_pane s -> Jv.of_string s
  | Z_index_offset i | Rise_offset i -> Jv.of_int i
  | Opacity f -> Jv.of_float f

let create_marker : Latlng.t -> marker_opt list -> [ `Marker ] t =
 fun latlng options ->
  let l =
    Array.of_list
    @@ List.map (fun o -> (marker_opt_to_string o, marker_opt_to_jv o)) options
  in
  let jv_t =
    Jv.call Global.leaflet "marker" [| Latlng.to_jv latlng; Jv.obj l |]
  in
  Marker jv_t

(** Tile layers *)

let create_tile_osm : string option -> [ `Tile ] t =
 fun url ->
  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