Source file event.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
open Base
open Js_of_ocaml
include Event_intf

type t = ..

type t +=
  | Ignore | Viewport_changed | Stop_propagation | Prevent_default | Many of t list

(* We use this table for dispatching to the appropriate handler in an efficient way.  *)
let handlers : (t -> unit) Hashtbl.M(Int).t = Hashtbl.create (module Int) ~size:8

(* All visibility handlers see all events, so a simple list is enough.  *)
let visibility_handlers : (unit -> unit) list ref = ref []

module Obj = struct
  module Extension_constructor = struct
    [@@@ocaml.warning "-3"]

    let id = Caml.Obj.extension_id
    let of_val = Caml.Obj.extension_constructor
  end
end

module Define (Handler : Handler) :
  S with type action := Handler.Action.t and type t := t = struct
  type t += C : Handler.Action.t -> t

  let key = Obj.Extension_constructor.id [%extension_constructor C]

  let () =
    Hashtbl.add_exn handlers ~key ~data:(fun inp ->
      match inp with
      | C value -> Handler.handle value
      | _ -> raise_s [%message "Unrecognized variant"])
  ;;

  let inject v = C v
end

module Define_visibility (VH : Visibility_handler) = struct
  let () = visibility_handlers := VH.handle :: !visibility_handlers
end

let get_key t = Obj.Extension_constructor.id (Obj.Extension_constructor.of_val t)
let handle_registered_event t = Hashtbl.find_exn handlers (get_key t) t

module Expert = struct
  let handle evt =
    let rec handle t =
      match t with
      | Ignore -> ()
      | Many l -> List.iter ~f:handle l
      | Viewport_changed -> List.iter !visibility_handlers ~f:(fun f -> f ())
      | Stop_propagation ->
        (* Safe to do because [stopPropagation] is defined equivalently to
           [preventDefault] *)
        Dom_html.stopPropagation evt
      | Prevent_default -> Dom.preventDefault evt
      | t -> handle_registered_event t
    in
    handle
  ;;


  let rec handle_non_dom_event_exn t =
    match t with
    | Ignore -> ()
    | Many l -> List.iter ~f:handle_non_dom_event_exn l
    | Viewport_changed -> List.iter !visibility_handlers ~f:(fun f -> f ())
    | Stop_propagation ->
      failwith
        "[handle_non_dom_event_exn] called with [Stop_propagation] which requires a dom \
         event"
    | Prevent_default ->
      failwith
        "[handle_non_dom_event_exn] called with [Prevent_default] which requires a dom \
         event"
    | t -> handle_registered_event t
  ;;
end