Browse Source

use gadts for event, clean repo

master
zapashcanon 4 months ago
parent
commit
f4ab3e17ad
Signed by: zapashcanon GPG Key ID: 8981C3C62D1D28F1
  1. 14
      src/dune
  2. 31
      src/ev.ml
  3. 66
      src/ev.mli
  4. 59
      src/event.ml
  5. 42
      src/event.mli
  6. 3
      src/leaflet.js.license
  7. 18
      src/map.ml
  8. 11
      src/map.mli

14
src/dune

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

31
src/ev.ml

@ -1,31 +0,0 @@
module Make () = struct
type t = Jv.t
let type' e = Jv.get e "type" |> Jv.to_string
let target e = Jv.get e "target" |> Brr.Ev.target_of_jv
let source_target e = Jv.get e "sourceTarget" |> Brr.Ev.target_of_jv
let propagated_from e = Jv.get e "propagatedFrom"
let latlng e = Latlng.of_jv_t @@ Jv.get e "latlng"
let layer_point e = Jv.get e "layerPoint"
let container_point e = Jv.get e "containerPoint"
let original_event e = Jv.get e "originalEvent"
let message e = Jv.get e "message" |> Jv.to_string
let code e = Jv.get e "code" |> Jv.to_int
end
module Event = Make ()
module Keyboard = Make ()
module Mouse = Make ()
module Error = Make ()

66
src/ev.mli

@ -1,66 +0,0 @@
module Event : sig
type t
val type' : t -> string
val target : t -> Brr.Ev.target
val source_target : t -> Brr.Ev.target
(* TODO this should return Point *)
val propagated_from : t -> Jv.t
end
module Keyboard : sig
type t
val type' : t -> string
val target : t -> Brr.Ev.target
val source_target : t -> Brr.Ev.target
val propagated_from : t -> Jv.t
(* TODO this should return BrrDomEvent*)
val original_event : t -> Jv.t
end
module Mouse : sig
type t
val type' : t -> string
val target : t -> Brr.Ev.target
val source_target : t -> Brr.Ev.target
val propagated_from : t -> Jv.t
val latlng : t -> Latlng.t
(* TODO this should return Point *)
val layer_point : t -> Jv.t
(* TODO this should return Point *)
val container_point : t -> Jv.t
(* TODO this should return BrrDomEvent*)
val original_event : t -> Jv.t
end
module Error : sig
type t
val type' : t -> string
val target : t -> Brr.Ev.target
val source_target : t -> Brr.Ev.target
val propagated_from : t -> Jv.t
val message : t -> string
val code : t -> int
end

59
src/event.ml

@ -0,0 +1,59 @@
type _ t =
| Keyboard : Jv.t -> [> `Keyboard ] t
| Mouse : Jv.t -> [> `Mouse ] t
| Error : Jv.t -> [> `Error ] t
| Basic : Jv.t -> [> `Basic ] t
type _ sub =
| Click : [> `Mouse ] sub
| Move_end : [> `Basic ] sub
| Zoom_end : [> `Basic ] sub
let of_jv_t : 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
let sub_to_string : type kind. kind sub -> string = function
| Click -> "click"
| Move_end -> "moveend"
| Zoom_end -> "zoomend"
(** Basic events *)
let get_type : type kind. kind t -> string = function
| Keyboard e | Mouse e | Error e | Basic e -> Jv.get e "type" |> Jv.to_string
let target : type kind. kind t -> Brr.Ev.target = function
| Keyboard e | Mouse e | Error e | Basic e ->
Jv.get e "target" |> Brr.Ev.target_of_jv
let source_target : type kind. kind t -> Brr.Ev.target = function
| Keyboard e | Mouse e | Error e | Basic e ->
Jv.get e "sourceTarget" |> Brr.Ev.target_of_jv
let propagated_from : type kind. kind t -> Jv.t = function
| Keyboard e | Mouse e | Error e | Basic e -> Jv.get e "propagatedFrom"
(** Keyboard & Mouse events *)
let original_event : [ `Keyboard | `Mouse ] t -> Jv.t = function
| Keyboard e | Mouse e -> Jv.get e "originalEvent"
(** Mouse events *)
let container_point : [ `Mouse ] t -> Jv.t = function
| Mouse e -> Jv.get e "containerPoint"
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
(** Error events *)
let code : [ `Error ] t -> int = function
| Error e -> Jv.get e "code" |> Jv.to_int
let message : [ `Error ] t -> string = function
| Error e -> Jv.get e "message" |> Jv.to_string

42
src/event.mli

@ -0,0 +1,42 @@
type _ t =
| Keyboard : Jv.t -> [> `Keyboard ] t
| Mouse : Jv.t -> [> `Mouse ] t
| Error : Jv.t -> [> `Error ] t
| Basic : Jv.t -> [> `Basic ] t
type _ sub =
| Click : [> `Mouse ] sub
| Move_end : [> `Basic ] sub
| Zoom_end : [> `Basic ] sub
val of_jv_t : 'a sub -> Jv.t -> 'a t
val sub_to_string : _ sub -> string
(** Basic events *)
val get_type : _ t -> string
val target : _ t -> Brr.Ev.target
val source_target : _ t -> Brr.Ev.target
val propagated_from : _ t -> Jv.t
(** Keyboard & Mouse events *)
val original_event : [ `Keyboard | `Mouse ] t -> Jv.t
(** Mouse events *)
val container_point : [ `Mouse ] t -> Jv.t
val layer_point : [ `Mouse ] t -> Jv.t
val latlng : [ `Mouse ] t -> Latlng.t
(** Error events *)
val code : [ `Error ] t -> int
val message : [ `Error ] t -> string

3
src/leaflet.js.license

@ -1,3 +0,0 @@
SPDX-FileCopyrightText: 2010-2021 Vladimir Agafonkin
SPDX-License-Identifier: BSD-2-Clause

18
src/map.ml

@ -1,15 +1,5 @@
type t = Jv.t
module Event = struct
let to_brr s = s |> Jstr.v |> Brr.Ev.Type.create
let click = to_brr "click"
let moveend = to_brr "moveend"
let zoomend = to_brr "zoomend"
end
let of_jv_t = Fun.id
let to_jv_t = Fun.id
@ -34,9 +24,11 @@ let set_view latlng ?zoom map =
let as_target map = Brr.Ev.target_of_jv map
let on ~event ~handler map =
let name = Brr.Ev.Type.name event |> Jv.of_jstr in
ignore @@ Jv.call map "on" [| name; Jv.repr handler |]
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 get_center map = Latlng.of_jv_t @@ Jv.call map "getCenter" [||]

11
src/map.mli

@ -1,14 +1,5 @@
type t
module Event : sig
(* TODO do this need to be wrapped in Brr.Ev.type' ?*)
val click : Ev.Mouse.t Brr.Ev.type'
val moveend : Ev.Event.t Brr.Ev.type'
val zoomend : Ev.Event.t Brr.Ev.type'
end
val create : ?options:Jv.t -> string -> t
val invalidate_size : t -> unit
@ -19,7 +10,7 @@ val fit_world : t -> unit
val get_container : t -> Brr.El.t
val on : event:'a Brr.Ev.type' -> handler:('a -> 'b) -> t -> unit
val on : 'a Event.sub -> ('a Event.t -> 'b) -> t -> unit
val get_center : t -> Latlng.t

Loading…
Cancel
Save