package bonsai

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

Source file focus.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
open! Core
open! Bonsai_web
open! Bonsai.Let_syntax
module Collated = Incr_map_collate.Collated

module By_row = struct
  type ('k, 'presence) t =
    { focused : 'presence
    ; unfocus : unit Effect.t
    ; focus_up : unit Effect.t
    ; focus_down : unit Effect.t
    ; page_up : unit Effect.t
    ; page_down : unit Effect.t
    ; focus : 'k -> unit Effect.t
    ; focus_index : int -> unit Effect.t
    }
  [@@deriving fields]

  type 'k optional = ('k, 'k option) t
end

module Kind = struct
  type ('a, 'presence, 'k) t =
    | None : (unit, unit, 'k) t
    | By_row :
        { on_change : ('k option -> unit Effect.t) Value.t
        ; compute_presence : 'k option Value.t -> 'presence Computation.t
        }
        -> (('k, 'presence) By_row.t, 'presence, 'k) t
end

type ('kind, 'key) t =
  { focus : 'kind
  ; visually_focused : 'key option
  }

module Row_machine = struct
  module Triple = struct
    (** This type is pretty integral to the row selection state-machine.  A
        value of this type is stored as the "currently selected row" and also
        as the result for "next row down" queries.  *)
    type 'k t =
      { key : 'k
      ; index : int
      }
    [@@deriving sexp, equal]
  end

  module Currently_selected_row = struct
    type 'k t =
      | At_key of 'k Triple.t
      | At_index of int
    [@@deriving sexp, equal]
  end

  let find_by collated ~f =
    with_return_option (fun { return } ->
      let i = ref (Collated.num_before_range collated) in
      collated
      |> Collated.to_map_list
      |> Map.iter ~f:(fun (key, _) ->
        if f ~key ~index:!i then return { Triple.key; index = !i } else Int.incr i))
  ;;

  let find_by_key collated ~key:needle ~key_equal =
    find_by collated ~f:(fun ~key ~index:_ -> key_equal key needle)
  ;;

  let find_by_index collated ~index:needle =
    with_return (fun { return } ->
      find_by collated ~f:(fun ~key:_ ~index ->
        if index > needle then return None;
        Int.equal index needle))
  ;;

  module Action = struct
    type 'key t =
      | Unfocus
      | Up
      | Down
      | Page_up
      | Page_down
      | Select of 'key
      | Select_index of int
      | Switch_from_index_to_key of
          { key : 'key
          ; index : int
          }
    [@@deriving sexp_of]
  end

  let component
        (type key data cmp presence)
        (key : (key, cmp) Bonsai.comparator)
        ~(compute_presence : key option Value.t -> presence Computation.t)
        ~(on_change : (key option -> unit Effect.t) Value.t)
        ~(collated : (key, data) Incr_map_collate.Collated.t Value.t)
        ~(range : (int * int) Value.t)
        ~(scroll_to_index : (int -> unit Effect.t) Value.t)
    : ((key, presence) By_row.t, key) t Computation.t
    =
    let module Key = struct
      include (val key)

      let equal a b = comparator.compare a b = 0
    end
    in
    let module Action = struct
      include Action

      type t = Key.t Action.t [@@deriving sexp_of]
    end
    in
    let module Model = struct
      (** [current] is the currently selected row.
          [shadow] is the previously selected row.

          Shadow is useful for computing "next row down" if the user previously
          unfocused, or if the element that was previously selected has been
          removed. *)
      type t =
        | No_focused_row
        | Shadow of Key.t Currently_selected_row.t
        | Visible of Key.t Currently_selected_row.t
      [@@deriving sexp, equal]

      let empty = No_focused_row
    end
    in
    let module Input = struct
      type t =
        { collated : (key, data) Collated.t
        ; range : int * int
        ; on_change : key option -> unit Ui_effect.t
        ; scroll_to_index : int -> unit Effect.t
        }
    end
    in
    let%sub input =
      let%arr collated = collated
      and range = range
      and on_change = on_change
      and scroll_to_index = scroll_to_index in
      { Input.collated; range; on_change; scroll_to_index }
    in
    let apply_action ~inject:_ ~schedule_event input (model : Model.t) action =
      match input with
      | Bonsai.Computation_status.Active
          { Input.collated; range = range_start, range_end; on_change; scroll_to_index }
        ->
        let scroll_to_index index = schedule_event (scroll_to_index index) in
        let update_focused_index ~f =
          let original_index =
            match model with
            | No_focused_row -> None
            | Shadow current | Visible current ->
              (match current with
               | At_index index -> Some index
               | At_key { key; index = old_index } ->
                 (match find_by_key collated ~key ~key_equal:Key.equal with
                  | Some { Triple.index; key = _ } -> Some index
                  | None -> Some old_index))
          in
          let new_index = f original_index in
          scroll_to_index new_index;
          let new_index =
            Int.max
              0
              (Int.min
                 new_index
                 (Collated.num_before_range collated
                  + Collated.num_after_range collated
                  + Collated.length collated
                  - 1))
          in
          Some
            (match find_by_index collated ~index:new_index with
             | Some triple -> Currently_selected_row.At_key triple
             | None -> At_index new_index)
        in
        let new_focus =
          match (action : Action.t) with
          | Switch_from_index_to_key { key; index } ->
            (* Before switching from index to key, we need to make sure that
               the focus is still at the that index. If it isn't, then we
               ignore the request to switch from index to key, since it is out
               of date. *)
            (match model with
             | No_focused_row -> None
             | Visible (At_index model_index) | Shadow (At_index model_index) ->
               if model_index = index
               then Some (Currently_selected_row.At_key { key; index })
               else Some (At_index model_index)
             | Visible (At_key _ as current) | Shadow (At_key _ as current) ->
               Some current)
          | Select key ->
            (match find_by_key ~key ~key_equal:Key.equal collated with
             | Some ({ index; key = _ } as triple) ->
               scroll_to_index index;
               Some (Currently_selected_row.At_key triple)
             | None -> None)
          | Unfocus -> None
          | Select_index new_index ->
            update_focused_index ~f:(fun _original_index -> new_index)
          | Down ->
            update_focused_index ~f:(function
              | Some original_index -> original_index + 1
              | None -> range_start)
          | Up ->
            update_focused_index ~f:(function
              | Some original_index -> original_index - 1
              | None -> range_end)
          | Page_down ->
            update_focused_index ~f:(function
              | Some original_index ->
                if original_index < range_end
                then range_end
                else original_index + (range_end - range_start)
              | None -> range_end)
          | Page_up ->
            update_focused_index ~f:(function
              | Some original_index ->
                if original_index > range_start
                then range_start
                else original_index - (range_end - range_start)
              | None -> range_start)
        in
        let new_model =
          match action with
          | Unfocus ->
            (match model with
             | No_focused_row -> Model.No_focused_row
             | Visible triple | Shadow triple -> Shadow triple)
          | _ ->
            (match new_focus with
             | Some triple -> Visible triple
             | None -> No_focused_row)
        in
        let prev_key =
          match model with
          | No_focused_row | Shadow _ | Visible (At_index _) -> None
          | Visible (At_key { key; _ }) -> Some key
        in
        let next_key =
          match new_model with
          | No_focused_row | Shadow _ | Visible (At_index _) -> None
          | Visible (At_key { key; _ }) -> Some key
        in
        if not ([%equal: Key.t option] prev_key next_key)
        then schedule_event (on_change next_key);
        new_model
      | Inactive ->
        eprint_s
          [%message
            [%here]
              "An action sent to a [state_machine1] has been dropped because its input \
               was not present. This happens when the [state_machine1] is inactive when \
               it receives a message."
              (action : Action.t)];
        model
    in
    let%sub current, inject =
      Bonsai.state_machine1
        (module Model)
        (module Action)
        ~default_model:Model.empty
        ~apply_action
        input
    in
    let%sub current = return (Value.cutoff ~equal:[%equal: Model.t] current) in
    let%sub everything_injectable =
      (* By depending on only [inject] (which is a constant), we can build the vast majority
         of this record, leaving only the "focused" field left unset, which we quickly fix.
         Doing it this way will mean that downstream consumers that only look at e.g. the "focus_up"
         field, won't have cutoff issues caused by [inject Up] being called every time that
         the model changes. *)
      let%arr inject = inject in
      { By_row.focused = None
      ; unfocus = inject Unfocus
      ; focus_up = inject Up
      ; focus_down = inject Down
      ; page_up = inject Page_up
      ; page_down = inject Page_down
      ; focus = (fun k -> inject (Select k))
      ; focus_index = (fun k -> inject (Select_index k))
      }
    in
    let%sub visually_focused =
      let%arr current = current
      and collated = collated in
      match current with
      | Visible (At_key { key; _ }) -> Some key
      | Visible (At_index index) ->
        (match find_by_index collated ~index with
         | Some { key; _ } -> Some key
         | None -> None)
      | No_focused_row | Shadow _ -> None
    in
    let%sub () =
      Bonsai.Edge.on_change
        (module struct
          type t = Model.t * Key.t option [@@deriving sexp, equal]
        end)
        (Value.both current visually_focused)
        ~callback:
          (let%map inject = inject in
           fun (current, visually_focused) ->
             (* If we ever notice that the state machine is focused at an index
                for which there is an existing row, we can request that the state
                machine switch over to being focused on the key at that index. *)
             match current with
             | Model.Visible (At_index index) ->
               (match visually_focused with
                | Some key -> inject (Switch_from_index_to_key { key; index })
                | None -> Effect.Ignore)
             | Visible (At_key _) | No_focused_row | Shadow _ -> Effect.Ignore)
    in
    let%sub presence = compute_presence visually_focused in
    let%arr presence = presence
    and visually_focused = visually_focused
    and everything_injectable = everything_injectable in
    let focus = { everything_injectable with By_row.focused = presence } in
    { focus; visually_focused }
  ;;
end

let component
  : type kind presence key.
    (kind, presence, key) Kind.t
    -> (key, _) Bonsai.comparator
    -> collated:(key, _) Collated.t Value.t
    -> range:_
    -> scroll_to_index:_
    -> (kind, key) t Computation.t
  =
  fun kind ->
  match kind with
  | None ->
    fun _ ~collated:_ ~range:_ ~scroll_to_index:_ ->
      Bonsai.const { focus = (); visually_focused = None }
  | By_row { on_change; compute_presence } ->
    Row_machine.component ~on_change ~compute_presence
;;

let get_focused (type r presence k)
  : (r, presence, k) Kind.t -> r Value.t -> presence Value.t
  =
  fun kind value ->
  match kind with
  | None -> Value.return ()
  | By_row _ ->
    let%map { focused; _ } = value in
    focused
;;

let get_on_row_click
      (type r presence k)
      (kind : (r, presence, k) Kind.t)
      (value : r Value.t)
  : (k -> unit Effect.t) Value.t
  =
  match kind with
  | None -> Value.return (fun _ -> Effect.Ignore)
  | By_row _ ->
    let%map { focus; _ } = value in
    focus
;;
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