Source file `bonsai_web_ui_widget.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
open! Core
open! Bonsai_web
open! Js_of_ocaml
open Bonsai.Let_syntax
open Virtual_dom

module Low_level = struct
  module Id = Unique_id.Int ()

  let zero = Id.create ()

  type 's t =
    { unsafe_init : 's -> Id.t
    ; unsafe_destroy : Id.t -> unit
    ; modify : ('s -> unit) -> unit Effect.t
    ; read : 'a. ('s -> 'a) -> 'a list Effect.t
    }

  module Model = struct
    type 's t = 's Id.Map.t

    let sexp_of_t = sexp_of_opaque
    let t_of_sexp = opaque_of_sexp
    let equal = phys_equal
  end

  module Action = struct
    type 's t =
      | Register of
          { id : Id.t
          ; state : 's
          }
      | Destroy of Id.t
      | Modify of ('s -> unit)

    let sexp_of_t = sexp_of_opaque
  end

  let component (type s) () =
    let module Model = struct
      include Model

      type nonrec t = s t
    end
    in
    let module Action = struct
      include Action

      type nonrec t = s t
    end
    in
    let%sub model, inject =
      Bonsai.state_machine0
        (module Model)
        (module Action)
        ~reset:(fun ~inject:_ ~schedule_event:_ m -> m)
        ~default_model:Id.Map.empty
        ~apply_action:(fun ~inject:_ ~schedule_event:_ model -> function
          | Register { id; state } -> Map.set model ~key:id ~data:state
          | Destroy id -> Map.remove model id
          | Modify f ->
            Map.iter model ~f;
            model)
    in
    let%sub get_model = Bonsai.yoink model in
    let%arr inject = inject
    and get_model = get_model in
    let unsafe_init state =
      let id = Id.create () in
      Effect.Expert.handle_non_dom_event_exn (inject (Register { id; state }));
      id
    in
    let unsafe_destroy id =
      Effect.Expert.handle_non_dom_event_exn (inject (Destroy id))
    in
    let modify f = inject (Modify f) in
    let read r =
      match%map.Effect get_model with
      | Inactive -> []
      | Active m -> List.map (Map.data m) ~f:r
    in
    { unsafe_init; unsafe_destroy; modify; read }
  ;;
end

module State = struct
  type ('input, 'state) t =
    { mutable input : 'input
    ; mutable state : 'state
    ; mutable id : Low_level.Id.t
    ; get_input : unit -> 'input
    }
end

type ('input, 'state) reader = { f : 'a. ('input -> 'state -> 'a) -> 'a list Effect.t }

type ('input, 'state) t =
  { view : Vdom.Node.t
  ; modify : ('input -> 'state -> unit) -> unit Effect.t
  ; read : 'a. ('input -> 'state -> 'a) -> 'a list Effect.t
  }

module type S = sig
  type element = private #Dom_html.element
  type input
  type state

  val init : get_input:(unit -> input) -> input -> state * element Js.t
  val update : prev_input:input -> input -> state -> element Js.t -> element Js.t
  val destroy : input -> state -> element Js.t -> unit
end

let component
      (type input state)
      ?(vdom_for_testing = fun _ -> Vdom.Node.create "widget" [])
      (module M : S with type input = input and type state = state)
      input
  =
  let id = Type_equal.Id.create ~name:"widget" sexp_of_opaque in
  let%sub state_tracker = Low_level.component () in
  let%sub view =
    let%arr input = input
    and { unsafe_init; unsafe_destroy; _ } = state_tracker in
    Vdom.Node.widget
      ~vdom_for_testing:(lazy (vdom_for_testing input))
      ~id
      ~init:(fun () ->
        let the_state = ref None in
        let get_input () =
          match !the_state with
          | None -> input
          | Some s -> s.State.input
        in
        let state, element = M.init ~get_input input in
        let s = { State.input; state; id = Low_level.zero; get_input } in
        the_state := Some s;
        let id = unsafe_init s in
        s.id <- id;
        s, element)
      ~update:(fun s element ->
        let { State.input = prev_input; state; get_input = _; id = _ } = s in
        if phys_equal input prev_input
        then s, element
        else (
          s.input <- input;
          let element = M.update ~prev_input input state element in
          s, element))
      ~destroy:(fun s element ->
        let { State.input; state; id; get_input = _ } = s in
        unsafe_destroy id;
        M.destroy input state element)
      ()
  in
  let%sub funs =
    let%arr state_tracker = state_tracker in
    let modify f = state_tracker.modify (fun s -> f s.input s.state) in
    let reader = { f = (fun f -> state_tracker.read (fun s -> f s.input s.state)) } in
    modify, reader
  in
  let%arr view = view
  and modify, reader = funs in
  { view; modify; read = reader.f }
;;