Source file `subscription.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
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
module Base = Fmlib_js.Base


type 'm t =
    | None
    | Window of string * 'm Handler.Virtual.t
    | Interval_timer  of int * (Time.t -> 'm)
    | Animation of (Time.t -> 'm)
    | Message of 'm Base.Decode.t
    | Url_request of (Navigation.url_request -> 'm)
    | Url_change of (Url.t -> 'm)
    | Batch  of 'm t list


let none: 'm t =
    None


let batch (lst: 'm t list): 'm t =
    Batch lst



let on_window (event_type: string) (decode: 'm Base.Decode.t)
    : 'm t
    =
    Window (event_type, Event_flag.(no_stop, no_prevent, decode))



let every (ms: int) (callback: Time.t -> 'm): 'm t =
    Interval_timer (ms, callback)


let on_animation (callback: Time.t -> 'm): 'm t =
    Animation callback



let on_message (decode: 'm Base.Decode.t): 'm t =
    Message decode


let on_url_request (f: Navigation.url_request -> 'm): 'm t =
    Url_request f


let on_url_change (f: Url.t -> 'm): 'm t =
    Url_change f



let map (f: 'a -> 'b) (sub:'a t): 'b t =
    let rec map =
        function
        | None ->
            None

        | Batch lst ->
            Batch (List.map map lst)

        | Window (event_type, decode) ->
            Window (event_type, Handler.Virtual.map f decode)

        | Interval_timer (millis, g) ->
            Interval_timer (millis, fun time -> f (g time))

        | Animation g ->
            Animation (fun time -> f (g time))

        | Message decode ->
            Message Base.Decode.(map f decode)

        | Url_request g ->
            Url_request (fun target -> f (g target))

        | Url_change g ->
            Url_change (fun target -> f (g target))
    in
    map sub



let decode_key_event (f: string -> 'm): 'm Base.Decode.t =
    Base.Decode.(map f (field "key" string))

let decode_mouse_event (f: int -> int -> 'm): 'm Base.Decode.t =
    Base.Decode.(
        let* x = field "clientX" int in
        let* y = field "clientY" int in
        return (f x y)
    )


let on_keydown (f: string -> 'm): 'm t =
    on_window "keydown" (decode_key_event f)

let on_keyup (f: string -> 'm): 'm t =
    on_window "keyup" (decode_key_event f)

let on_mouse_down (f: int -> int -> 'm): 'm t =
    on_window "mousedown" (decode_mouse_event f)

let on_mouse_move (f: int -> int -> 'm): 'm t =
    on_window "mousemove" (decode_mouse_event f)

let on_mouse_up (f: int -> int -> 'm): 'm t =
    on_window "mouseup" (decode_mouse_event f)



let on_resize (f: int -> int -> 'm): 'm t =
    let decode = Base.Decode.(
        let* _ = return () in
        field "currentTarget" (
            let* width  = field "innerWidth" int in
            let* height = field "innerHeight" int in
            return (f width height)
        )
    )
    in
    on_window "resize" decode


let on_visibility_change (f: string -> 'm): 'm t =
    let decode = Base.Decode.(
        field "target" (
            (* The target of the visibility change event is "document" and
               "document" has the "visibilityState" property. *)
            let* state = field "visibilityState" string in
            return (f state)
        )
    )
    in
    on_window "visibilitychange" decode