package bonsai

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

Source file start.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
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
open! Core
open! Async_kernel
open! Import
open Js_of_ocaml

module type Result_spec = sig
  type t
  type extra
  type incoming

  val view : t -> Vdom.Node.t
  val extra : t -> extra
  val incoming : t -> incoming -> unit Vdom.Effect.t
end

module Arrow_deprecated = struct
  module Handle = struct
    module Injector = struct
      type 'a t =
        | Before_app_start of 'a Queue.t
        | Inject of ('a -> unit Vdom.Effect.t)
    end

    type ('input, 'extra, 'incoming, 'outgoing) t =
      { mutable injector : 'incoming Injector.t
      ; stop : unit Ivar.t
      ; started : unit Ivar.t
      ; input_var : 'input Incr.Var.t
      ; outgoing_pipe : 'outgoing Pipe.Reader.t
      ; extra : ('extra -> unit) Bus.Read_write.t
      ; last_extra : 'extra Moption.t
      }

    let create ~input_var ~outgoing_pipe =
      let extra =
        Bus.create_exn
          [%here]
          Arity1
          ~on_subscription_after_first_write:Allow_and_send_last_value
          ~on_callback_raise:(fun error -> eprint_s [%sexp (error : Error.t)])
      in
      let last_extra = Moption.create () in
      Bus.iter_exn extra [%here] ~f:(fun extra -> Moption.set_some last_extra extra);
      { injector = Before_app_start (Queue.create ())
      ; stop = Ivar.create ()
      ; started = Ivar.create ()
      ; input_var
      ; outgoing_pipe
      ; extra
      ; last_extra
      }
    ;;

    let stop t = Ivar.fill_if_empty t.stop ()
    let started t = Ivar.read t.started

    let schedule t a =
      match t.injector with
      | Inject f -> f a |> Vdom.Effect.Expert.handle_non_dom_event_exn
      | Before_app_start queue -> Queue.enqueue queue a
    ;;

    let set_started t = Ivar.fill_if_empty t.started ()

    let set_inject t inject =
      let prev = t.injector in
      t.injector <- Inject inject;
      match prev with
      | Inject _ -> ()
      | Before_app_start queue -> Queue.iter queue ~f:(schedule t)
    ;;

    let input t = Incr.Var.value t.input_var
    let set_input t input = Incr.Var.set t.input_var input
    let update_input t ~f = set_input t (f (input t))
    let outgoing { outgoing_pipe; _ } = outgoing_pipe
    let extra t = Bus.read_only t.extra
    let last_extra t = Moption.get t.last_extra
  end

  module App_input = struct
    type ('input, 'outgoing) t =
      { input : 'input
      ; inject_outgoing : 'outgoing -> unit Vdom.Effect.t
      }
    [@@deriving fields]

    let create = Fields.create
  end

  module App_result = struct
    type ('extra, 'incoming) t =
      { view : Vdom.Node.t
      ; extra : 'extra
      ; inject_incoming : 'incoming -> unit Vdom.Effect.t
      }
    [@@deriving fields]

    let create = Fields.create

    let of_result_spec
          (type result extra incoming)
          (module Result : Result_spec
            with type t = result
             and type extra = extra
             and type incoming = incoming)
          (r : Result.t)
      =
      { view = Result.view r
      ; extra = Result.extra r
      ; inject_incoming = Result.incoming r
      }
    ;;
  end

  let make_instrumented_computation ?host ?port ?worker_name component =
    let open Option.Let_syntax in
    match
      [%map
        let host = host
        and port = port
        and worker_name = worker_name in
        host, port, worker_name]
    with
    | Some (host, port, worker_name) ->
      Forward_performance_entries.instrument ~host ~port ~worker_name component
    | None ->
      print_endline "debugger host and port not be specified";
      { Forward_performance_entries.instrumented_computation = component
      ; shutdown = (fun () -> ())
      }
  ;;

  type debugging_state =
    | Not_debugging
    | Debugging of
        { host : string option
        ; port : int option
        ; worker_name : string option
        }

  let start_bonsai_debugger
        (is_debugging_var : debugging_state Incr.Var.t)
        (host : Js.js_string Js.t Js.Optdef.t)
        (port : int Js.Optdef.t)
        (worker_name : Js.js_string Js.t Js.Optdef.t)
    =
    match Incr.Var.value is_debugging_var with
    | Debugging _ -> print_endline "Already debugging."
    | Not_debugging ->
      print_endline "Starting the debugger.";
      Incr.Var.set
        is_debugging_var
        (Debugging
           { host = Js.Optdef.to_option host |> Option.map ~f:Js.to_string
           ; port = Js.Optdef.to_option port
           ; worker_name = Js.Optdef.to_option worker_name |> Option.map ~f:Js.to_string
           })
  ;;

  let start_generic_poly
        (type input action_input input_and_inject model dynamic_action static_action result
                extra incoming outgoing)
        ~(get_app_result : result -> (extra, incoming) App_result.t)
        ~(get_app_input :
            input:input
          -> inject_outgoing:(outgoing -> unit Vdom.Effect.t)
          -> input_and_inject)
        ~(initial_input : input)
        ~bind_to_element_with_id
        ~(computation : result Bonsai.Private.Computation.t)
        ~fresh
        ({ model
         ; input = _
         ; dynamic_action
         ; static_action
         ; apply_static
         ; apply_dynamic
         ; run
         ; reset = _
         } as info :
           ( model
           , dynamic_action
           , static_action
           , action_input
           , result )
             Bonsai.Private.Computation.info)
    : (input, extra, incoming, outgoing) Handle.t
    =
    let outgoing_pipe, pipe_write = Pipe.create () in
    let module Out_event =
      Virtual_dom.Vdom.Effect.Define (struct
        module Action = struct
          type t = outgoing
        end

        let handle = Pipe.write_without_pushback_if_open pipe_write
      end)
    in
    let input_var = Incr.Var.create initial_input in
    let handle = Handle.create ~input_var ~outgoing_pipe in
    let input =
      let%map.Incr input = Incr.Var.watch input_var in
      get_app_input ~input ~inject_outgoing:Out_event.inject
    in
    let prev_lifecycle = ref Bonsai.Private.Lifecycle.Collection.empty in
    let is_debugging_var = Incr.Var.create Not_debugging in
    let debugger_shutdown = ref None in
    let module Incr_dom_app = struct
      module Model = struct
        type t = model

        let cutoff = phys_equal
      end

      module State = struct
        type t = unit
      end

      module Action = struct
        let sexp_of_dynamic_action =
          Bonsai.Private.Meta.Action.Type_id.to_sexp dynamic_action
        ;;

        let sexp_of_static_action =
          Bonsai.Private.Meta.Action.Type_id.to_sexp static_action
        ;;

        type t =
          | Dynamic of dynamic_action
          | Static of static_action
        [@@deriving sexp_of]
      end

      let action_requires_stabilization = function
        | Action.Dynamic _ -> true
        | Static _ -> false
      ;;

      let on_startup ~schedule_action:_ _ = return ()

      let create
            model
            ~old_model:_
            ~inject
            (run :
               ( model
               , dynamic_action
               , static_action
               , action_input
               , result )
                 Bonsai.Private.Computation.eval_fun)
        =
        let open Incr.Let_syntax in
        let environment =
          Bonsai.Private.Environment.(empty |> add_exn ~key:fresh ~data:input)
        in
        let inject_dynamic a = inject (Action.Dynamic a) in
        let inject_static a = inject (Action.Static a) in
        let snapshot =
          run
            ~environment
            ~path:Bonsai.Private.Path.empty
            ~clock:Incr.clock
            ~model
            ~inject_dynamic
            ~inject_static
        in
        let%map view =
          let%map { App_result.view; extra; inject_incoming } =
            snapshot |> Bonsai.Private.Snapshot.result >>| get_app_result
          in
          Handle.set_inject handle inject_incoming;
          Bus.write handle.extra extra;
          view
        and apply_action =
          let%map input =
            snapshot
            |> Bonsai.Private.Snapshot.input
            |> Bonsai.Private.Input.to_incremental
          in
          fun () ~schedule_event model action ->
            match action with
            | Action.Dynamic action ->
              apply_dynamic
                ~inject_dynamic
                ~inject_static
                ~schedule_event
                (Some input)
                model
                action
            | Action.Static action ->
              apply_static ~inject_dynamic ~inject_static ~schedule_event model action
        and on_display =
          let%map lifecycle = Bonsai.Private.Snapshot.lifecycle_or_empty snapshot in
          fun () ~schedule_event ->
            Handle.set_started handle;
            schedule_event
              (Bonsai.Private.Lifecycle.Collection.diff !prev_lifecycle lifecycle);
            prev_lifecycle := lifecycle
        in
        let update_visibility model ~schedule_event:_ = model in
        { Incr_dom.App_intf.Private.view; apply_action; update_visibility; on_display }
      ;;

      let create model ~old_model ~inject =
        let open Incr.Let_syntax in
        let safe_start computation =
          let (T info') = Bonsai.Private.gather computation in
          match
            Bonsai.Private.Meta.(
              ( Model.Type_id.same_witness info.model.type_id info'.model.type_id
              , Action.Type_id.same_witness info.dynamic_action info'.dynamic_action
              , Action.Type_id.same_witness info.static_action info'.static_action
              , Input.same_witness info.input info'.input ))
          with
          | Some T, Some T, Some T, Some T -> create model ~old_model ~inject info'.run
          | _ ->
            print_endline
              "Not starting debugger. An error occurred while attempting to instrument \
               the computation; the resulting computation does not typecheck. Reusing \
               previously gathered run information to execute";
            create model ~old_model ~inject run
        in
        match%bind Incr.Var.watch is_debugging_var with
        | Debugging { host; port; worker_name } ->
          let { Forward_performance_entries.instrumented_computation; shutdown } =
            make_instrumented_computation ?host ?port ?worker_name computation
          in
          debugger_shutdown := Some shutdown;
          safe_start instrumented_computation
        | Not_debugging -> safe_start computation
      ;;
    end
    in
    Incr_dom.Start_app.Private.start_bonsai
      ~bind_to_element_with_id
      ~initial_model:model.default
      ~stop:(Ivar.read handle.stop)
      (module Incr_dom_app);
    let start_bonsai_debugger dry_run host port worker_name =
      let print_message () =
        print_endline
          "Not starting debugger. Be aware that running the debugger will send \
           performance data to the debugger server, which may be unacceptable if the \
           data you work with is sensitive. Consider running a local server and calling \
           this function again with the local host and port. If you wish to proceed, run \
           this function again, passing \"true\" as the first parameter"
      in
      Js.Optdef.case dry_run print_message (fun dry_run ->
        if Js.to_bool dry_run
        then (
          start_bonsai_debugger is_debugging_var host port worker_name;
          Incr.stabilize ())
        else print_message ())
    in
    let stop_bonsai_debugger () =
      Option.iter !debugger_shutdown ~f:(fun f -> f ());
      debugger_shutdown := None;
      Incr.Var.set is_debugging_var Not_debugging;
      Incr.stabilize ()
    in
    Js.Unsafe.global##.startBonsaiDebugger := Js.Unsafe.callback start_bonsai_debugger;
    Js.Unsafe.global##.stopBonsaiDebugger := Js.Unsafe.callback stop_bonsai_debugger;
    handle
  ;;

  let start_generic
        ~optimize
        ~get_app_result
        ~initial_input
        ~bind_to_element_with_id
        ~component
    =
    let fresh = Type_equal.Id.create ~name:"" sexp_of_opaque in
    let var =
      Bonsai.Private.Value.named App_input fresh |> Bonsai.Private.conceal_value
    in
    let computation =
      component var
      |> Bonsai.Private.reveal_computation
      |> if optimize then Bonsai.Private.pre_process else Fn.id
    in
    let (T info) = Bonsai.Private.gather computation in
    start_generic_poly
      ~get_app_result
      ~initial_input
      ~bind_to_element_with_id
      ~computation
      ~fresh
      info
  ;;

  (* I can't use currying here because of the value restriction. *)
  let start_standalone
        ?(optimize = true)
        ~initial_input
        ~bind_to_element_with_id
        component
    =
    start_generic
      ~optimize
      ~get_app_result:(fun view ->
        { App_result.view; extra = (); inject_incoming = Nothing.unreachable_code })
      ~get_app_input:(fun ~input ~inject_outgoing:_ -> input)
      ~initial_input
      ~bind_to_element_with_id
      ~component
  ;;

  let start ?(optimize = true) ~initial_input ~bind_to_element_with_id component =
    start_generic
      ~optimize
      ~get_app_result:Fn.id
      ~get_app_input:App_input.create
      ~initial_input
      ~bind_to_element_with_id
      ~component
  ;;
end

module Proc = struct
  module Handle = struct
    include Arrow_deprecated.Handle

    type ('extra, 'incoming) t =
      (unit, 'extra, 'incoming, Nothing.t) Arrow_deprecated.Handle.t
  end

  module Result_spec = struct
    module type S = Result_spec

    type ('r, 'extra, 'incoming) t =
      (module S with type t = 'r and type extra = 'extra and type incoming = 'incoming)

    module No_extra = struct
      type extra = unit

      let extra _ = ()
    end

    module No_incoming = struct
      type incoming = Nothing.t

      let incoming _ = Nothing.unreachable_code
    end

    let just_the_view =
      (module struct
        type t = Vdom.Node.t

        let view = Fn.id

        include No_extra
        include No_incoming
      end : S
        with type t = Vdom.Node.t
         and type extra = unit
         and type incoming = Nothing.t)
    ;;
  end

  let start_and_get_handle
        result_spec
        ?(optimize = true)
        ?(custom_connector = fun _ -> assert false)
        ~bind_to_element_with_id
        computation
    =
    let computation =
      Rpc_effect.Private.with_connector
        (function
          | Self -> Rpc_effect.Private.self_connector ()
          | Url url -> Rpc_effect.Private.url_connector url
          | Custom custom -> custom_connector custom)
        computation
    in
    let bonsai =
      Fn.const computation
      |> Bonsai.Arrow_deprecated.map
           ~f:(Arrow_deprecated.App_result.of_result_spec result_spec)
    in
    Arrow_deprecated.start ~optimize ~initial_input:() ~bind_to_element_with_id bonsai
  ;;

  let start ?custom_connector ?(bind_to_element_with_id = "app") component =
    let (_ : _ Handle.t) =
      start_and_get_handle
        Result_spec.just_the_view
        ~bind_to_element_with_id
        ?custom_connector
        component
    in
    ()
  ;;
end
OCaml

Innovation. Community. Security.

GitHub Discord Twitter Peertube RSS
About
Changelog Releases Industrial Users Academic Users Why OCaml
Ecosystem
Packages Community Events OCaml Planet Jobs
Resources
Install OCaml Get Started Platform Tools Language Manual Standard Library API Books Exercises Papers OCaml Playground Logo
Policies
Carbon Footprint Governance Privacy Code of Conduct