package bonsai

  1. Overview
  2. Docs
package bonsai
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file proc_min.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
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
open! Core
open! Import
open Computation

let read x = Return x

let sub (type via) ?here (from : via Computation.t) ~f =
  match from with
  | Return { here = there; value = Named _ as named; id } ->
    let here = Option.first_some here there in
    f { Value.here; value = named; id }
  | _ ->
    let via : via Type_equal.Id.t =
      Type_equal.Id.create
        ~name:(Source_code_position.to_string [%here])
        [%sexp_of: opaque]
    in
    let into = f (Value.named (Sub here) via) in
    Sub { from; via; into; here }
;;

let switch ~here ~match_ ~branches ~with_ =
  let arms =
    Int.Map.of_increasing_sequence
      (Sequence.map (Sequence.range 0 branches) ~f:(fun key ->
         let computation =
           try with_ key with
           | exn -> read (Value.return_exn exn)
         in
         key, computation))
    |> Or_error.ok_exn
  in
  Switch { match_; arms; here }
;;

let reset_to_default
      ~default_model
      ~inject_dynamic:_
      ~inject_static:_
      ~schedule_event:_
      _prev_model
  =
  default_model
;;

let build_resetter reset ~default_model ~f =
  let ignore_absurd : (Nothing.t -> 'a) -> unit = ignore in
  Option.value_map reset ~default:(reset_to_default ~default_model) ~f:(fun a ->
    f ~ignore_absurd a)
;;

module Dynamic_scope = struct
  let fetch ~id ~default ~for_some = Fetch { id; default; for_some }
  let store ~id ~value ~inner = Store { id; value; inner }
end

module Edge = struct
  let lifecycle t = Lifecycle t
end

let state_machine01
      (type da)
      model
      (module Dynamic_action : Action with type t = da)
      static_action
      ?reset
      ~default_model
      ~apply_dynamic
      ~apply_static
      input
  =
  let reset = Option.value reset ~default:(reset_to_default ~default_model) in
  let name = Source_code_position.to_string [%here] in
  let apply_dynamic ~inject_dynamic ~inject_static ~schedule_event input model action =
    match input with
    | Some input ->
      apply_dynamic ~inject_dynamic ~inject_static ~schedule_event input model action
    | None ->
      eprint_s
        [%message
          "An action sent to a [state_machine01] has been dropped because its input was \
           not present. This happens when the [state_machine01] is inactive when it \
           receives a message."
            (action : Dynamic_action.t)];
      model
  in
  Leaf01
    { model = Meta.Model.of_module model ~name ~default:default_model
    ; input_id = Meta.Input.create ()
    ; dynamic_action = Meta.Action.of_module (module Dynamic_action) ~name
    ; static_action = Meta.Action.of_module static_action ~name
    ; apply_dynamic
    ; apply_static
    ; input
    ; reset
    }
;;

let state_machine1_safe model dynamic_action ?reset ~default_model ~apply_action input =
  let name = Source_code_position.to_string [%here] in
  let reset =
    build_resetter
      reset
      ~default_model
      ~f:(fun ~ignore_absurd reset ~inject_dynamic ~inject_static ->
        ignore_absurd inject_static;
        reset ~inject:inject_dynamic)
  in
  let apply_action ~inject_dynamic ~inject_static:_ =
    apply_action ~inject:inject_dynamic
  in
  Leaf1
    { model = Meta.Model.of_module model ~name ~default:default_model
    ; input_id = Meta.Input.create ()
    ; dynamic_action = Meta.Action.of_module dynamic_action ~name
    ; apply_action
    ; reset
    ; input
    }
;;

module Computation_status = struct
  type 'input t =
    | Active of 'input
    | Inactive
  [@@deriving sexp_of]

  let of_option = function
    | Some x -> Active x
    | None -> Inactive
  ;;
end

let state_machine1
      model
      (type da)
      (module Dynamic_action : Action with type t = da)
      ?reset
      ~default_model
      ~apply_action
      input
  =
  let apply_action ~inject ~schedule_event input model action =
    let input = Computation_status.of_option input in
    apply_action ~inject ~schedule_event input model action
  in
  state_machine1_safe
    model
    (module Dynamic_action)
    ?reset
    ~default_model
    ~apply_action
    input
;;

let state_machine0 ?reset model static_action ~default_model ~apply_action =
  let name = Source_code_position.to_string [%here] in
  let apply_action ~inject_dynamic:_ ~inject_static =
    apply_action ~inject:inject_static
  in
  let reset =
    build_resetter
      reset
      ~default_model
      ~f:(fun ~ignore_absurd reset ~inject_dynamic ~inject_static ->
        ignore_absurd inject_dynamic;
        reset ~inject:inject_static)
  in
  Leaf0
    { model = Meta.Model.of_module model ~name ~default:default_model
    ; static_action = Meta.Action.of_module static_action ~name
    ; apply_action
    ; reset
    }
;;

module Proc_incr = struct
  let value_cutoff t ~equal = read (Value.cutoff ~added_by_let_syntax:false ~equal t)

  let compute_with_clock t ~f =
    Computation.Leaf_incr { input = t; input_id = Meta.Input.create (); compute = f }
  ;;

  let of_module
        (type input model result)
        (module M : Component_s_incr
          with type Input.t = input
           and type Model.t = model
           and type Result.t = result)
        ~(default_model : model)
        (input : input Value.t)
    : result Computation.t
    =
    sub
      (state_machine1
         (module M.Model)
         (module M.Action)
         ~default_model
         ~apply_action:(fun ~inject ~schedule_event input model action ->
           match input with
           | Active input -> M.apply_action input ~inject ~schedule_event model action
           | Inactive ->
             eprint_s
               [%message
                 [%here]
                   "An action sent to an [of_module] has been dropped because its input \
                    was not present. This happens when the [of_module] is inactive when \
                    it receives a message."
                   (action : M.Action.t)];
             model)
         input)
      ~f:(fun state ->
        compute_with_clock (Value.both input state) ~f:(fun _clock input_and_state ->
          let%pattern_bind.Ui_incr input, (model, inject) = input_and_state in
          M.compute input model ~inject))
  ;;
end

let assoc
      (type k v cmp)
      (comparator : (k, cmp) comparator)
      (map : (k, v, cmp) Map.t Value.t)
      ~f
  =
  let module C = (val comparator) in
  let key_id : k Type_equal.Id.t = Type_equal.Id.create ~name:"key id" C.sexp_of_t in
  let cmp_id : cmp Type_equal.Id.t =
    Type_equal.Id.create ~name:"cmp id" [%sexp_of: opaque]
  in
  let data_id : v Type_equal.Id.t =
    Type_equal.Id.create ~name:"data id" [%sexp_of: opaque]
  in
  let key_var = Value.named Assoc_like_key key_id in
  let data_var = Value.named Assoc_like_data data_id in
  let by = f key_var data_var in
  Assoc { map; key_comparator = comparator; key_id; cmp_id; data_id; by }
;;

let assoc_on
      (type model_k io_k model_cmp io_cmp v)
      (io_comparator : (io_k, io_cmp) comparator)
      (model_comparator : (model_k, model_cmp) comparator)
      (map : (io_k, v, io_cmp) Map.t Value.t)
      ~get_model_key
      ~f
  =
  let module Io_comparator = (val io_comparator) in
  let module Model_comparator = (val model_comparator) in
  let io_key_id : io_k Type_equal.Id.t =
    Type_equal.Id.create ~name:"io key id" Io_comparator.sexp_of_t
  in
  let io_cmp_id : io_cmp Type_equal.Id.t =
    Type_equal.Id.create ~name:"io cmp id" [%sexp_of: opaque]
  in
  let model_key_id : model_k Type_equal.Id.t =
    Type_equal.Id.create ~name:"model key id" Model_comparator.sexp_of_t
  in
  let model_cmp_id : model_cmp Type_equal.Id.t =
    Type_equal.Id.create ~name:"model key id" [%sexp_of: opaque]
  in
  let data_id : v Type_equal.Id.t =
    Type_equal.Id.create ~name:"data id" [%sexp_of: opaque]
  in
  let key_var = Value.named Assoc_like_key io_key_id in
  let data_var = Value.named Assoc_like_data data_id in
  let by = f key_var data_var in
  Assoc_on
    { map
    ; io_comparator
    ; model_comparator
    ; io_key_id
    ; io_cmp_id
    ; data_id
    ; model_key_id
    ; model_cmp_id
    ; by
    ; get_model_key
    }
;;

let lazy_ t = Lazy t

let wrap (type model action) ?reset model_module ~default_model ~apply_action ~f =
  let model_id : model Type_equal.Id.t =
    Type_equal.Id.create ~name:"model id" [%sexp_of: opaque]
  in
  let module M = struct
    type t = action

    let sexp_of_t = [%sexp_of: opaque]
  end
  in
  let reset =
    build_resetter
      reset
      ~default_model
      ~f:(fun ~ignore_absurd reset ~inject_dynamic ~inject_static ->
        ignore_absurd inject_static;
        reset ~inject:inject_dynamic)
  in
  let action_id = Meta.Action.of_module (module M) ~name:"action id" in
  let result_id = Meta.Input.create () in
  let inject_id : (action -> unit Effect.t) Type_equal.Id.t =
    Type_equal.Id.create ~name:"inject id" [%sexp_of: opaque]
  in
  let apply_action ~inject_dynamic ~inject_static:_ ~schedule_event result model action =
    match result with
    | Some result ->
      apply_action ~inject:inject_dynamic ~schedule_event result model action
    | None ->
      eprint_s
        [%message
          "An action sent to a [wrap] has been dropped because its input was not \
           present. This happens when the [wrap] is inactive when it receives a message."
            (action : M.t)];
      model
  in
  let model_var = Value.named Wrap_model model_id in
  let inject_var = Value.named Wrap_inject inject_id in
  let inner = f model_var inject_var in
  let wrapper_model =
    Meta.Model.of_module model_module ~default:default_model ~name:"outer model for wrap"
  in
  Wrap
    { wrapper_model
    ; action_id
    ; result_id
    ; inject_id
    ; model_id
    ; inner
    ; dynamic_apply_action = apply_action
    ; reset
    }
;;

let with_model_resetter f =
  let reset_id = Type_equal.Id.create ~name:"reset-model" [%sexp_of: opaque] in
  let inner = f ~reset:(Value.named Model_resetter reset_id) in
  With_model_resetter { reset_id; inner }
;;

let path = Path

include Computation