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
open Fmlib_js

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 (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: Url.t -> 'm): 'm t =
    Url_request 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 url -> f (g url))
    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