package bonsai

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

Source file bonsai_web_ui_query_box.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
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
open! Core
open Bonsai_web
open Bonsai.Let_syntax
open Vdom

module Model = struct
  type 'k suggestion_list_state =
    | Closed
    | First_item
    | Selected of 'k
  [@@deriving equal, sexp, compare]

  type 'k t =
    { query : string
    ; suggestion_list_state : 'k suggestion_list_state
    ; offset : int
    }
  [@@deriving equal, sexp]
end

module Action = struct
  type 'k t =
    | Set_query of string
    | Move_next
    | Move_prev
    | Move_to of
        { key : 'k
        ; offset : int
        }
    | Move_next_with_fixed_offset
    | Move_prev_with_fixed_offset
    | Close_suggestions
    | Open_suggestions
  [@@deriving sexp]
end

module Suggestion_list_kind = struct
  type t =
    | Transient_overlay
    | Permanent_fixture
  [@@deriving sexp, compare, enumerate, equal]
end

module Expand_direction = struct
  type t =
    | Down
    | Up
  [@@deriving sexp, compare, enumerate, equal]
end

let select_key ~first_try ~then_try ~else_use =
  match first_try with
  | Some (key, _) -> Model.Selected key
  | None ->
    (match then_try with
     | (lazy (Some (key, _))) -> Model.Selected key
     | (lazy None) -> else_use)
;;

type 'k t =
  { selected_item : 'k option
  ; view : Vdom.Node.t
  ; query : string
  }
[@@deriving fields]

let create
      (type k cmp)
      (module Key : Bonsai.Comparator with type t = k and type comparator_witness = cmp)
      ?(initial_query = "")
      ?(max_visible_items = Value.return 10)
      ?(suggestion_list_kind = Value.return Suggestion_list_kind.Transient_overlay)
      ?(expand_direction = Value.return Expand_direction.Down)
      ?(selected_item_attr = Value.return Attr.empty)
      ?(extra_list_container_attr = Value.return Attr.empty)
      ?(extra_input_attr = Value.return Attr.empty)
      ?(extra_attr = Value.return Attr.empty)
      ~f
      ~on_select
      ()
  =
  let%sub { Model.query; suggestion_list_state; offset }, inject, items, _ =
    Bonsai.wrap
      (module struct
        type t = Key.t Model.t [@@deriving sexp]

        let equal a b = Model.equal (fun a b -> Key.comparator.compare a b = 0) a b
      end)
      ~default_model:
        { Model.query = initial_query; suggestion_list_state = Closed; offset = 0 }
      ~apply_action:
        (fun
          ~inject:_ ~schedule_event:_ (_, _, items, max_visible_items) model action ->
          let suggestion_list_state =
            (* We normalize which item is selected in case the list has changed
               since the last action. Normalization just means setting the
               selected key to the closest thing that actually exists. *)
            match model.suggestion_list_state with
            | Selected key ->
              select_key
                ~first_try:(Map.closest_key items `Less_or_equal_to key)
                ~then_try:(lazy (Map.closest_key items `Greater_or_equal_to key))
                ~else_use:First_item
            | First_item -> First_item
            | Closed -> Closed
          in
          let next_suggestion_list_state () =
            match suggestion_list_state with
            | Selected key ->
              select_key
                ~first_try:(Map.closest_key items `Greater_than key)
                ~then_try:(lazy (Map.min_elt items))
                ~else_use:(Selected key)
            | First_item ->
              (match Map.min_elt items with
               | None -> First_item
               | Some (first_key, _) ->
                 (match Map.closest_key items `Greater_than first_key with
                  | None -> Selected first_key
                  | Some (second_key, _) -> Selected second_key))
            | Closed -> First_item
          in
          let prev_suggestion_list_state () =
            match model.suggestion_list_state with
            | Selected key ->
              select_key
                ~first_try:(Map.closest_key items `Less_than key)
                ~then_try:(lazy (Map.max_elt items))
                ~else_use:(Selected key)
            | First_item | Closed ->
              (match Map.max_elt items with
               | None -> First_item
               | Some (last_key, _) -> Selected last_key)
          in
          match action with
          | Action.Set_query query ->
            let suggestion_list_state =
              match suggestion_list_state with
              | Selected key -> Model.Selected key
              | First_item | Closed -> First_item
            in
            let offset = model.offset in
            { Model.query; suggestion_list_state; offset }
          | Open_suggestions -> { model with suggestion_list_state = First_item }
          | Close_suggestions -> { model with suggestion_list_state = Closed }
          | Move_next ->
            let suggestion_list_state = next_suggestion_list_state () in
            let offset =
              let comparison =
                Model.compare_suggestion_list_state
                  (Map.comparator items).compare
                  model.suggestion_list_state
                  suggestion_list_state
              in
              if comparison = 0
              then model.offset
              else if comparison < 0
              then min (max_visible_items - 1) (model.offset + 1)
              else 0
            in
            { model with suggestion_list_state; offset }
          | Move_prev ->
            let suggestion_list_state = prev_suggestion_list_state () in
            let offset =
              let comparison =
                Model.compare_suggestion_list_state
                  (Map.comparator items).compare
                  model.suggestion_list_state
                  suggestion_list_state
              in
              if comparison = 0
              then model.offset
              else if comparison < 0
              then max_visible_items - 1
              else max 0 (model.offset - 1)
            in
            { model with suggestion_list_state; offset }
          | Move_to { key; offset } ->
            if Map.mem items key
            then { model with suggestion_list_state = Selected key; offset }
            else model
          | Move_next_with_fixed_offset ->
            { model with suggestion_list_state = next_suggestion_list_state () }
          | Move_prev_with_fixed_offset ->
            { model with suggestion_list_state = prev_suggestion_list_state () })
      ~f:(fun model inject ->
        let%sub { Model.query; _ } = return model in
        let%sub items = f query in
        let%arr model = model
        and inject = inject
        and items = items
        and max_visible_items = max_visible_items in
        model, inject, items, max_visible_items)
  in
  let%sub selected_key =
    match%sub suggestion_list_state with
    | Selected key ->
      let%arr key = key
      and items = items in
      (match Map.closest_key items `Less_or_equal_to key with
       | Some (key, _) -> Some key
       | None ->
         (match Map.closest_key items `Greater_or_equal_to key with
          | Some (key, _) -> Some key
          | None -> None))
    | First_item ->
      let%arr items = items in
      (match Map.min_elt items with
       | Some (key, _) -> Some key
       | None -> None)
    | Closed -> Bonsai.const None
  in
  let%sub items =
    let%arr items = items
    and max_visible_items = max_visible_items
    and selected_key = selected_key
    and offset = offset in
    match selected_key with
    | Some selected_key ->
      let length = ref 0 in
      let items = ref items in
      let result = ref (Map.empty (module Key)) in
      (* We alternate between taking something larger and smaller than the
         selected key until we have taken [max_visible_items] or have exhausted
         the source list. This is probably not done in the most efficient
         manner, but it's O(max_visible_items * log(number_of_items)), which is
         probably acceptable if [max_visible_items] is small. *)
      let visible_items = min max_visible_items (Map.length !items) in
      let offset = min offset visible_items in
      let add_element_from_side side =
        match Map.closest_key !items side selected_key with
        | Some (key, data) ->
          result := Map.set !result ~key ~data;
          items := Map.remove !items key;
          incr length;
          true
        | None -> false
      in
      while !length < visible_items do
        (* An invariant of this loop is that we will always increment [length]
           every iteration, thus guaranteeing the termination of the loop. This
           is guaranteed because [visible_items] is defined to be at most the
           length of the map of items being pulled from, which ensures that we
           won't run out of items collect until we have met the desired length. *)
        if !length <= offset
        then (
          if not (add_element_from_side `Less_or_equal_to)
          then ignore (add_element_from_side `Greater_or_equal_to : bool))
        else if not (add_element_from_side `Greater_or_equal_to)
        then ignore (add_element_from_side `Less_or_equal_to : bool)
      done;
      !result
    | None ->
      Map.subrange
        items
        ~lower_bound:Unbounded
        ~upper_bound:
          (match Map.nth items max_visible_items with
           | Some (k, _) -> Excl k
           | None -> Unbounded)
  in
  let%sub get_items = Bonsai.yoink items in
  let%sub items =
    Bonsai.assoc
      (module Key)
      items
      ~f:(fun key item ->
        let%arr key = key
        and item = item
        and get_items = get_items
        and selected_key = selected_key
        and selected_item_attr = selected_item_attr
        and inject = inject
        and on_select = on_select in
        let selected_attr =
          match selected_key with
          | Some selected_key when Key.comparator.compare key selected_key = 0 ->
            selected_item_attr
          | _ -> Attr.empty
        in
        let move_to_effect =
          let%bind.Effect items =
            match%bind.Effect get_items with
            | Active items -> Effect.return items
            | Inactive ->
              Effect.never
          in
          let%bind.Effect offset = Effect.of_sync_fun (Map.rank items) key in
          let offset = Option.value offset ~default:0 in
          inject (Move_to { key; offset })
        in
        let attr =
          Attr.many
            [ selected_attr
            ; Attr.on_mouseenter (fun _ -> move_to_effect)
            ; Attr.on_click (fun _ ->
                let%bind.Effect () = inject (Set_query "") in
                let%bind.Effect () = inject Close_suggestions in
                on_select key)
            ]
        in
        Node.div ~attrs:[ attr ] [ item ])
  in
  let%sub handle_keydown =
    let%arr inject = inject
    and selected_key = selected_key
    and on_select = on_select
    and expand_direction = expand_direction in
    let open Vdom in
    let open Js_of_ocaml in
    fun ev ->
      let move_next = Effect.Many [ inject Move_next; Effect.Prevent_default ] in
      let move_prev = Effect.Many [ inject Move_prev; Effect.Prevent_default ] in
      let up, down =
        match expand_direction with
        | Up -> move_next, move_prev
        | Down -> move_prev, move_next
      in
      match Dom_html.Keyboard_code.of_event ev with
      | ArrowUp -> up
      | Tab when Js.to_bool ev##.shiftKey ->
        (match selected_key with
         | Some _ -> up
         | None -> Effect.Ignore)
      | ArrowDown -> down
      | Tab ->
        (match selected_key with
         | Some _ -> down
         | None -> Effect.Ignore)
      | Escape -> inject Action.Close_suggestions
      | Enter ->
        (match selected_key with
         | Some key ->
           Effect.Many
             [ on_select key
             ; inject (Set_query "")
             ; inject Close_suggestions
             ; Effect.Prevent_default
             ]
         | None -> inject Open_suggestions)
      | _ -> Effect.Ignore
  in
  let%sub suggestion_container_id = Bonsai.path_id in
  let%sub input_id = Bonsai.path_id in
  let%arr query = query
  and selected_key = selected_key
  and inject = inject
  and handle_keydown = handle_keydown
  and suggestion_list_kind = suggestion_list_kind
  and expand_direction = expand_direction
  and items = items
  and extra_list_container_attr = extra_list_container_attr
  and extra_input_attr = extra_input_attr
  and extra_attr = extra_attr
  and suggestion_container_id = suggestion_container_id
  and input_id = input_id in
  let container_position, suggestions_position, is_open =
    match suggestion_list_kind with
    | Suggestion_list_kind.Transient_overlay ->
      let is_open = Option.is_some selected_key in
      ( Attr.style (Css_gen.position `Relative)
      , Attr.style (Css_gen.position `Absolute)
      , is_open )
    | Permanent_fixture -> Attr.empty, Attr.empty, true
  in
  let on_blur =
    Attr.on_blur
      (let open Js_of_ocaml in
       fun (ev : Dom_html.focusEvent Js.t) ->
         (* Blurring usually means that we want to close the suggestion list.
            However, if we are blurring the text input in order to focus the
            list of items (or vice versa), we want to keep the list open. Thus,
            we check whether the relatedTarget of the event is one of those two
            elements, in which case we don't close the list. *)
         match
           Option.bind (Js.Optdef.to_option ev##.relatedTarget) ~f:Js.Opt.to_option
         with
         | Some related_target ->
           let id = Js.to_string related_target##.id in
           if String.equal id suggestion_container_id || String.equal id input_id
           then Effect.Ignore
           else inject Close_suggestions
         | None -> inject Close_suggestions)
  in
  let input =
    Node.input
      ~attrs:
        [ Attr.id input_id
        ; Attr.type_ "text"
        ; Attr.string_property "value" query
        ; Attr.on_keydown handle_keydown
        ; Attr.on_input (fun _ query -> inject (Set_query query))
        ; Attr.on_focus (fun _ -> inject Open_suggestions)
        ; on_blur
        ; extra_input_attr
        ]
      ()
  in
  let suggestions =
    match is_open with
    | false -> Node.div []
    | true ->
      let position_above_or_below, directed_items =
        match expand_direction with
        | Up -> Attr.style (Css_gen.bottom (`Px 0)), items |> Map.data |> List.rev
        | Down -> Attr.empty, Map.data items
      in
      let attr =
        Attr.(suggestions_position @ position_above_or_below @ extra_list_container_attr)
      in
      Node.div ~attrs:[ attr ] directed_items
  in
  let suggestions_container =
    Node.div
      ~attrs:
        [ Attr.create "data-test" "query-box-item-container"
        ; Attr.id suggestion_container_id
        ; Attr.tabindex (-1)
        ; Attr.on_wheel
            (let open Js_of_ocaml in
             fun (ev : Js_of_ocaml_patches.Dom_html.wheelEvent Js.t) ->
               let comparison =
                 match expand_direction with
                 | Down -> Float.( < ) ev##.deltaY 0.0
                 | Up -> Float.( > ) ev##.deltaY 0.0
               in
               Effect.Many
                 [ (if comparison
                    then inject Move_prev_with_fixed_offset
                    else inject Move_next_with_fixed_offset)
                 ; Effect.Prevent_default
                 ])
        ; on_blur
        ; container_position
        ]
      [ suggestions ]
  in
  let view =
    Node.div
      ~attrs:[ extra_attr ]
      (match expand_direction with
       | Up -> [ suggestions_container; input ]
       | Down -> [ input; suggestions_container ])
  in
  { selected_item = selected_key; view; query }
;;

let stringable
      (type k cmp)
      (module Key : Bonsai.Comparator with type t = k and type comparator_witness = cmp)
      ?initial_query
      ?max_visible_items
      ?suggestion_list_kind
      ?expand_direction
      ?selected_item_attr
      ?extra_list_container_attr
      ?extra_input_attr
      ?extra_attr
      ?(to_view = fun _ string -> Vdom.Node.text string)
      ~on_select
      input
  =
  create
    (module Key)
    ?initial_query
    ?max_visible_items
    ?suggestion_list_kind
    ?expand_direction
    ?selected_item_attr
    ?extra_list_container_attr
    ?extra_input_attr
    ?extra_attr
    ~on_select
    ~f:(fun query ->
      Bonsai.Incr.compute (Value.both query input) ~f:(fun incr ->
        let%pattern_bind.Incr query, input = incr in
        Incr_map.filter_mapi' input ~f:(fun ~key ~data:string ->
          let%map.Incr string = string
          and query = query in
          if Fuzzy_match.is_match ~char_equal:Char.Caseless.equal ~pattern:query string
          then Some (to_view key string)
          else None)))
    ()
;;

module Collate_map_with_score = struct
  module Scored_key = struct
    module T = struct
      type 'k t = int * 'k

      let sexp_of_t (x, _) = sexp_of_int x
      let t_of_sexp _ = assert false
      let compare (a, _) (b, _) = Int.compare a b
    end

    include T
    include Comparator.Make1 (T)

    module M (T : T) = struct
      type nonrec t = T.t t
      type nonrec comparator_witness = comparator_witness

      let sexp_of_t = sexp_of_t
      let t_of_sexp = t_of_sexp
      let comparator = comparator
    end

    module Map = struct
      type nonrec ('k, 'v) t = ('k t, 'v, comparator_witness) Map.t
    end
  end

  let collate (type k) ~preprocess ~score ~query_is_as_strict ~to_result input query =
    let empty_result =
      Map.empty
        (module Scored_key.M (struct
             type t = k
           end))
    in
    Bonsai.Incr.compute (Value.both input query) ~f:(fun input_and_query ->
      let%pattern_bind.Ui_incr input, query = input_and_query in
      let%bind.Ui_incr input = input in
      let len = Map.length input in
      let array = Uniform_array.unsafe_create_uninitialized ~len in
      let () =
        let index = ref 0 in
        Map.iteri input ~f:(fun ~key ~data ->
          Uniform_array.set array !index (key, data, preprocess ~key ~data);
          incr index)
      in
      (* We keep track of an arbitrary number of queries. Each
         time the query changes, we discard any queries for which the new query
         is not merely a refinement of. In other words, we maintain the
         invariant that each item in this list of queries is strictly more
         general than the previous one. *)
      let previous_queries = ref [] in
      (* In addition, we also keep track of the index (from the back of the
         list of queries, rather than the front, but this doesn't matter
         because we never use the index to get an element out of the list)
         of the first query that eliminated an item from the set of result. *)
      let filtered_out_at_index = Array.create ~len Int.max_value in
      let%map.Ui_incr query = query in
      let rec trim_queries qs =
        match qs with
        | [] -> []
        | q :: qs -> if query_is_as_strict query ~as_:q then q :: qs else trim_queries qs
      in
      previous_queries := query :: trim_queries !previous_queries;
      let num_queries = List.length !previous_queries in
      Uniform_array.foldi
        array
        ~init:empty_result
        ~f:(fun index acc (key, data, preprocessed) ->
          let score =
            (* If the item was already filtered out by a previous query, we can
               keep filtering it out. If instead it was filtered out by a query
               that have since discarded (or, possibly, it was never filtered
               out), then we need to re-evaluate the score. *)
            if filtered_out_at_index.(index) < num_queries
            then 0
            else (
              let score = score query preprocessed in
              filtered_out_at_index.(index)
              <- (if score = 0 then num_queries else Int.max_value);
              score)
          in
          if score = 0
          then acc
          else (
            (* The first component of the key compares equivalently to the pair
               (score, index), but faster, since it is only an integer. Note
               that the map comparator doesn't need to inspect the key itself,
               since [index] already captures that ordering. Thus, this whole
               computation remains fast even if the input map comparator is
               extremely slow. *)
            let new_key = (len * score) + index, key in
            Map.add_exn acc ~key:new_key ~data:(to_result preprocessed ~key ~data))))
  ;;
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