package bonsai

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

Source file multi_factor.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
open! Core
open! Import
open  Multi_factor_intf

module type S   = S
module type Key = Key

module Make (Item : Single_factor.Item) (Key : Key) = struct
  module Single_factor = Single_factor.Make (Item)

  module Ring_focus = struct
    module Action = struct
      type t =
        | Cycle_focused_subwidget of [ `Next | `Prev ]
        | Set_focused_subwidget   of Key.t
      [@@deriving sexp_of]
    end

    module Model = struct
      type t = Key.t Focus_ring.t [@@deriving compare, equal, sexp]
    end

    module Result = struct
      type t = Key.t * (Action.t -> unit Bonsai_web.Effect.t)
    end

    module Input = Unit

    let apply_action ~inject:_ ~schedule_event:_ () model action =
      match (action : Action.t) with
      | Cycle_focused_subwidget `Next -> Focus_ring.next model
      | Cycle_focused_subwidget `Prev -> Focus_ring.prev model
      | Set_focused_subwidget key     ->
        Focus_ring.set model ~f:(fun key' -> [%compare.equal: Key.t] key key')
        |> Option.value ~default:model
    ;;

    let compute ~inject () model = Focus_ring.current_focus model, inject
    let name                     = Source_code_position.to_string [%here]
  end

  module Action = struct
    type t =
      | Cycle_focused_subwidget  of [ `Next | `Prev ]
      | Set_focused_subwidget    of Key.t
      | Subwidget_action         of Key.t * Single_factor.Action.t
      | Select_on_all_subwidgets of [ `All | `None ]
    [@@deriving sexp_of]
  end

  type per_subwidget =
    { default_selection_status : Selection_status.t
    ; all_items                : Item.Set.t
    }
  [@@deriving fields]

  module Result = struct
    type t =
      { view             : Vdom.Node.t
      ; view_for_testing : string Lazy.t
      ; key_handler      : Vdom_keyboard.Keyboard_event_handler.t
      ; inject           : Action.t -> unit Vdom.Effect.t
      ; selection        : Item.Set.t Key.Map.t
      }
    [@@deriving fields]

    let view_with_keydown_handler t =
      let open Vdom in
      let on_keydown =
        Attr.on_keydown (fun ev ->
          Vdom_keyboard.Keyboard_event_handler.handle_or_ignore_event t.key_handler ev)
      in
      Node.div ~attrs:[ on_keydown ] [ t.view ]
    ;;
  end

  let search_box_id key ~id_prefix = sprintf !"%s-search-box-%{Key}" id_prefix key

  let view ~inject ~focus ~subwidgets ~id_prefix =
    let open Vdom in
    let cross_subwidget_actions =
      let link ~text ~(action : Action.t) =
        Node.a
          ~attrs:
            [ Attr.many_without_merge
                [ Attr.href "about:blank"
                ; Attr.on_click (fun _ev ->
                    Effect.Many [ inject action; Effect.Prevent_default ])
                ]
            ]
          [ Node.text text ]
      in
      Node.div
        [ Node.text (sprintf "Select on all %s: " Key.name_plural)
        ; link ~text:"all" ~action:(Select_on_all_subwidgets `All)
        ; Node.text "; "
        ; link ~text:"none" ~action:(Select_on_all_subwidgets `None)
        ]
    in
    let subwidgets =
      Map.mapi subwidgets ~f:(fun ~key ~data:result ->
        let is_focused = [%compare.equal: Key.t] focus key in
        Node.div
          ~attrs:
            [ Attr.many_without_merge
                [ Attr.classes
                    [ "multi-factor-subwidget"
                    ; (if is_focused
                       then "multi-factor-focused-subwidget"
                       else "multi-factor-unfocused-subwidget")
                    ]
                ; Attr.on_click (fun _ev -> inject (Set_focused_subwidget key))
                ; Attr.id (sprintf !"%s-%{Key}" id_prefix key)
                ]
            ]
          [ result.Single_factor.Result.view ])
    in
    Vdom_layout.as_vbox
      Node.div
      [ cross_subwidget_actions; Vdom_layout.as_hbox Node.div (Map.data subwidgets) ]
  ;;

  let key_handler ~inject ~focus ~subwidgets =
    let open Vdom_keyboard in
    let my_key_handler =
      let command ?cond ~keys ~description f =
        let handler =
          let open Keyboard_event_handler.Handler in
          match cond with
          | None      -> with_prevent_default f
          | Some cond -> only_handle_if cond  f ~prevent_default:()
        in
        { Keyboard_event_handler.Command.keys; description; group = None; handler }
      in
      let key = Keystroke.create' in
      Keyboard_event_handler.of_command_list_exn
        [ command
            ~keys:[ key Tab ]
            ~description:(sprintf "Focus next %s" Key.name_singular)
            (fun _ev -> inject (Action.Cycle_focused_subwidget `Next))
        ; command
            ~keys:[ key ~shift:() Tab ]
            ~description:(sprintf "Focus prev %s" Key.name_singular)
            (fun _ev -> inject (Cycle_focused_subwidget `Prev))
        ]
    in
    let focused_subwidget_key_handler =
      let result = Map.find_exn subwidgets focus in
      result.Single_factor.Result.key_handler
    in
    Keyboard_event_handler.merge
      focused_subwidget_key_handler
      my_key_handler
      ~on_dup:`Override_with_right
  ;;

  let inject ~subwidgets ~inject_ring_focus_action = function
    | Action.Cycle_focused_subwidget dir ->
      inject_ring_focus_action (Ring_focus.Action.Cycle_focused_subwidget dir)
    | Set_focused_subwidget key -> inject_ring_focus_action (Set_focused_subwidget key)
    | Subwidget_action (key, a) ->
      (match Map.find subwidgets key with
       | None -> Bonsai.Effect.Ignore
       | Some { Single_factor.Result.inject; _ } -> inject a)
    | Select_on_all_subwidgets what ->
      Bonsai.Effect.Many
        (List.map (Map.data subwidgets) ~f:(fun subwidget ->
           subwidget.inject
             (match what with
              | `All  -> Select_all
              | `None -> Select_none)))
  ;;

  let view_for_testing ~subwidgets ~focus =
    lazy
      (let columns =
         List.map (Map.keys subwidgets) ~f:(fun key ->
           let name =
             sprintf
               !"%s %{Key}"
               (if [%compare.equal: Key.t] focus key then "*" else " ")
               key
           in
           Ascii_table_kernel.Column.create name (fun () ->
             let subwidget = Map.find_exn subwidgets key in
             Lazy.force subwidget.Single_factor.Result.view_for_testing))
       in
       Ascii_table_kernel.draw
         columns
         [ () ]
         ~limit_width_to:2000
         ~prefer_split_on_spaces:false
       |> Option.value_exn
       |> Ascii_table_kernel.Screen.to_string
            ~bars:`Unicode
            ~string_with_attr:(fun _attrs str -> str))
  ;;

  let focus_elt id =
    let open Js_of_ocaml in
    (* In tests, there is no [document] object, so we can't focus elements. *)
    if Js.Optdef.test (Js.def Dom_html.document)
    then
      Option.iter
        (Dom_html.getElementById_coerce id Dom_html.CoerceTo.input)
        ~f:(fun elt ->
          elt##focus;
          elt##select)
  ;;

  let focus_elt =
    let f = Effect.of_sync_fun focus_elt in
    fun ~id -> f id
  ;;

  let bonsai ?(initial_model_settings = Key.Map.empty) ~all_keys ~id_prefix subwidgets =
    let open Bonsai.Let_syntax in
    let single_factor key input =
      let default_selection_status = input >>| default_selection_status in
      let initial_model_settings =
        Map.find initial_model_settings key
        |> Option.value ~default:(Single_factor.Initial_model_settings.create ())
      in
      let view_config =
        let%map id_prefix = id_prefix in
        Single_factor.View_config.create
          ~id:(search_box_id key ~id_prefix)
          ~header:(Vdom.Node.text (Key.to_string key))
          ()
      in
      Single_factor.bonsai
        ~initial_model_settings
        ~default_selection_status
        ~view_config
        (input >>| all_items)
    in
    let%sub single_factors =
      all_keys
      |> Set.to_map ~f:(fun key ->
        match%sub subwidgets >>| Fn.flip Map.find key with
        | Some input -> Computation.map (single_factor key input) ~f:Option.some
        | None       -> Bonsai.const None)
      |> Computation.all_map
      |> Computation.map ~f:(Map.filter_map ~f:Fn.id)
    in
    let%sub focus, inject_focus_action =
      Bonsai.of_module0
        (module Ring_focus)
        ~default_model:(Focus_ring.of_nonempty_list_exn (Set.to_list all_keys))
    in
    let%sub () =
      let callback =
        let%map id_prefix = id_prefix in
        fun prev new_focus ->
          match prev with
          | Some prev_focus when Key.equal prev_focus new_focus -> Effect.Ignore
          | None | Some _ -> focus_elt ~id:(search_box_id new_focus ~id_prefix)
      in
      Bonsai.Edge.on_change' (module Key) focus ~callback
    in
    let%arr subwidgets = single_factors
    and focus                    = focus
    and inject_ring_focus_action = inject_focus_action
    and id_prefix                = id_prefix in
    let inject = inject ~subwidgets ~inject_ring_focus_action in
    let selection =
      Map.map subwidgets ~f:(fun result -> result.Single_factor.Result.selected_items)
    in
    let view             = view ~inject        ~subwidgets ~focus ~id_prefix in
    let view_for_testing = view_for_testing    ~subwidgets ~focus            in
    let key_handler      = key_handler ~inject ~subwidgets ~focus            in
    { Result.selection; view; view_for_testing; key_handler; inject }
  ;;
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