Source file `subscriptions.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
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
open Fmlib_js

module String_map = Fmlib_std.Btree.Map (String)
module Int_map  = Fmlib_std.Btree.Map (Int)

module Intionary  = Dictionary.Make (Int)
module Dictionary = Dictionary.Make (String)

module Subs =
struct
    type 'm handler = 'm Handler.Virtual.t

    type 'm t = {

        window: 'm handler list Dictionary.t;

        timers: (Time.t -> 'm) list Intionary.t;

        animation: (Time.t -> 'm) option;

        message: 'm Base.Decode.t option;

        url_request: (Url.t -> 'm) option
    }


    let empty: 'm t = {
        window      = Dictionary.empty;
        timers      = Intionary.empty;
        animation   = None;
        message     = None;
        url_request = None;
    }


    let make (sub: 'm Subscription.t): 'm t =
        let open Subscription in
        let rec make subs = function
            | None ->
                subs

            | Batch lst ->
                List.fold_left
                    make
                    subs
                    lst
            | Window (event_type, handler) ->
                {subs with
                 window =
                     Dictionary.set
                         event_type
                         (function
                             | None ->
                                 [handler]
                             | Some lst ->
                                 handler :: lst
                         )
                         subs.window}

            | Interval_timer (millis, callback) ->
                {subs with
                 timers =
                     Intionary.set
                         millis
                         (function
                             | None ->
                                 [callback]
                             | Some lst ->
                                 callback :: lst
                         )
                         subs.timers}


            | Animation callback ->
                {subs with
                 animation = Some callback;
                }

            | Message decode ->
                {subs with
                 message =
                     match subs.message with
                     | None ->
                         Some decode
                     | Some _ ->
                         subs.message}

            | Url_request f ->
                {subs with
                 url_request =
                     match subs.url_request with
                     | None ->
                         Some f
                     | Some _ ->
                         subs.url_request}
        in
        make empty sub
end








type 'm t = {
    subs:   'm Subs.t;
    window: Handler.EventHs.t;
    timers: Handler.Timers.t;
    url_request: Handler.Url_request.t
}




let make (dispatch: 'm -> unit) (sub: 'm Subscription.t): 'm t =
    let subs   = Subs.make sub in
    let open Handler in

    let window = EventHs.empty () in
    EventHs.set
        Fmlib_js.Dom.Window.(event_target (get ()))
        dispatch
        subs.window
        window;

    let timers = Timers.empty () in
    Timers.set dispatch subs.timers timers;

    let url_request = Url_request.empty () in
    Url_request.set dispatch subs.url_request url_request;
    { subs; window; timers; url_request }



let update (dispatch: 'm -> unit) (sub: 'm Subscription.t) (s: 'm t): 'm t =
    let subs   = Subs.make sub in
    let open Handler in
    EventHs.update
        Fmlib_js.Dom.Window.(event_target (get ()))
        dispatch
        subs.window
        s.subs.window
        s.window;
    Timers.update dispatch subs.timers s.subs.timers s.timers;
    Url_request.update
        dispatch
        subs.url_request
        s.subs.url_request
        s.url_request;
    { s with subs }