package bonsai

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

Source file form.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
open! Core
open Import
open Form_view
module Toggle = Bonsai_web_ui_toggle

let rec view_error (e : Error.Internal_repr.t) : Vdom.Node.t list =
  let bold text = Vdom.Node.strong [ Vdom.Node.text text ] in
  let pre text = Vdom.Node.pre [ Vdom.Node.text text ] in
  let view_sexp sexp = pre (Sexp.to_string_hum sexp) in
  let div contents = Vdom.Node.div [ contents ] in
  match e with
  | Could_not_construct sexp -> [ div (view_sexp sexp) ]
  | String s -> [ div (Vdom.Node.text s) ]
  | Exn e -> [ div (pre (Exn.to_string e)) ]
  | Sexp s -> [ div (view_sexp s) ]
  | Tag_sexp (string, sexp, Some there) ->
    [ div (bold string)
    ; div (view_sexp sexp)
    ; div (pre (Source_code_position.to_string there))
    ]
  | Tag_sexp (string, sexp, None) -> [ div (bold string); div (view_sexp sexp) ]
  | Tag_t (string, error) -> div (bold string) :: view_error error
  | Tag_arg (string, sexp, error) ->
    div (bold string) :: div (view_sexp sexp) :: view_error error
  | Of_list (Some truncate_after, errors) ->
    errors |> Fn.flip List.take truncate_after |> List.concat_map ~f:view_error
  | Of_list (None, errors) -> List.concat_map ~f:view_error errors
  | With_backtrace (error, backtrace) ->
    List.append (view_error error) [ div (pre backtrace) ]
;;

let view_error error = view_error (Error.Internal_repr.of_info error)

(* A form is disabled if it is not editable *)
let disabled_of_editable = function
  | `Currently_no -> true
  | `Yes_always | `Currently_yes -> false
;;

let render_append_item self ~eval_context append_item =
  match append_item with
  | Append_view view -> view
  | Append_info { append; text } ->
    let text = Option.value text ~default:"Add new element" in
    self#button
      ~attrs:[ Vdom.Attr.type_ "button" ]
      ~disabled:(disabled_of_editable (Form_context.editable eval_context))
      ~intent:None
      ~tooltip:None
      ~on_click:append
      [ Vdom.Node.text text ]
;;

let render_remove_item self ~eval_context remove_item ~index =
  match remove_item with
  | Remove_view view -> view
  | Remove_info { remove; element_label } ->
    let delete_button =
      self#button
        ~attrs:
          [ Vdom.Attr.many
              [ Vdom.Attr.type_ "button"
              ; Vdom.Attr.style
                  Css_gen.(
                    border ~style:`None ()
                    @> create ~field:"cursor" ~value:"pointer"
                    @> color (`Name "blue")
                    @> create ~field:"background" ~value:"none")
              ]
          ]
        ~disabled:(disabled_of_editable (Form_context.editable eval_context))
        ~intent:None
        ~tooltip:None
        ~on_click:remove
        [ Vdom.Node.text "[ remove ]" ]
    in
    (match element_label with
     | None -> Vdom.Node.div [ Vdom.Node.textf "%d - " index; delete_button ]
     | Some f -> f ~delete_button index)
;;

let view_error_details self error =
  let constants : Constants.t = self#constants in
  Toggle.view
    { Toggle.Colors.toggle_text = constants.form.error_toggle_text
    ; inner_background = constants.form.error_message.background
    ; inner_border = constants.form.error_border
    ; inner_text = constants.form.error_message.foreground
    }
    ~toggle:(Vdom.Node.text "⚠")
    ~inner:(Vdom.Node.div (self#form_view_error error))
    ~direction:`Right
;;

let view_tooltip self inner =
  let constants : Constants.t = self#constants in
  Toggle.view
    { Toggle.Colors.inner_text = constants.form.tooltip_message.foreground
    ; inner_border = constants.form.tooltip_border
    ; inner_background = constants.form.tooltip_message.background
    ; toggle_text = constants.form.tooltip_toggle_text
    }
    ~toggle:(Vdom.Node.text "ⓘ")
    ~inner
    ~direction:`Above
;;

let wrap_tooltip_and_error self ~tooltip ~error =
  match Option.is_none tooltip && Option.is_none error with
  | true -> Vdom.Node.none
  | false ->
    let tooltip =
      Option.value_map tooltip ~f:self#form_view_tooltip ~default:Vdom.Node.none
    in
    let error =
      Option.value_map error ~f:self#form_view_error_details ~default:(Vdom.Node.text "")
    in
    Vdom.Node.td
      [ Vdom.Node.div
          ~attrs:[ Vdom.Attr.style (Css_gen.flex_container ~direction:`Row ()) ]
          [ tooltip; error ]
      ]
;;

let depth_td' ~depth ~extra_attrs =
  let attr = Vdom.Attr.(style (Css_gen.padding_left (`Em depth)) @ extra_attrs) in
  Vdom.Node.td ~attrs:[ attr ]
;;

let depth_td_of_context context = depth_td' ~depth:(Form_context.depth context)

let render_label
      ?id
      ?colspan
      ?(extra_attrs = [])
      label
      ~(depth_td : extra_attrs:Vdom.Attr.t -> ?key:string -> Vdom.Node.t list -> Vdom.Node.t)
  =
  let colspan = Option.value_map colspan ~default:Vdom.Attr.empty ~f:Vdom.Attr.colspan in
  let for_ = Option.value_map id ~default:Vdom.Attr.empty ~f:Vdom.Attr.for_ in
  let label =
    match label with
    | None -> Vdom.Node.text ""
    | Some label ->
      Vdom.Node.label ~attrs:[ for_; Vdom.Attr.style (Css_gen.display `Block) ] [ label ]
  in
  depth_td ~extra_attrs:(Vdom.Attr.many (colspan :: extra_attrs)) [ label ]
;;

let render_context_above self ~view_context ~eval_context =
  let depth_td = depth_td_of_context eval_context in
  let inhabited_header =
    Option.is_some view_context.label
    || Option.is_some view_context.error
    || Option.is_some view_context.tooltip
  in
  match inhabited_header with
  | false -> []
  | true ->
    let label =
      render_label
        ~extra_attrs:[ Vdom.Attr.style (Css_gen.font_weight `Bold) ]
        ~colspan:2
        ~depth_td
        view_context.label
    in
    let tooltip_and_error =
      wrap_tooltip_and_error ~tooltip:view_context.tooltip ~error:view_context.error
    in
    [ Vdom.Node.tr [ label; tooltip_and_error self ] ]
;;

let render_context_inline self ?id inline_view ~view_context ~eval_context =
  let depth_td = depth_td_of_context eval_context in
  let inline_view = Vdom.Node.td [ inline_view ] in
  let label_attrs =
    [ Vdom.Attr.style
        Css_gen.(
          padding_right (`Em 1)
          @> text_align `Left
          @> font_weight `Bold
          @> user_select `None)
    ]
  in
  let label = render_label ?id ~extra_attrs:label_attrs ~depth_td view_context.label in
  let tooltip_and_error =
    wrap_tooltip_and_error ~tooltip:view_context.tooltip ~error:view_context.error
  in
  (* This key prevents inputs of different "kinds" from clobbering each other *)
  Vdom.Node.tr ?key:id [ label; inline_view; tooltip_and_error self ]
;;

let empty ~eval_context:_ ~view_context:_ () = []

let collapsible
      self
      ~eval_context
      ~view_context
      ({ collapse_label; state } : Form_view.collapsible)
  =
  let tooltip_and_error =
    wrap_tooltip_and_error self ~tooltip:view_context.tooltip ~error:view_context.error
  in
  let label =
    Vdom.Node.tr
      [ render_label
          ~extra_attrs:[ Vdom.Attr.style (Css_gen.font_weight `Bold) ]
          ~colspan:2
          (Some collapse_label)
          ~depth_td:(depth_td_of_context eval_context)
      ; tooltip_and_error
      ]
  in
  let rest =
    match state with
    | Collapsed None -> []
    | Collapsed (Some t) | Expanded t ->
      self#form_view ~eval_context:(Form_context.incr_depth eval_context) t
  in
  label :: rest
;;

let tuple self ~eval_context ~view_context ts =
  render_context_above self ~view_context ~eval_context
  @ List.concat_map ts ~f:(self#form_view ~eval_context)
;;

let raw self ~eval_context ~view_context ({ raw_view; id } : Form_view.raw) =
  [ render_context_inline
      self
      ~id
      (raw_view view_context ~editable:(Form_context.editable eval_context))
      ~view_context
      ~eval_context
  ]
;;

let record self ~eval_context ~view_context fields =
  let rest =
    List.concat_map fields ~f:(fun { field_name; field_view } ->
      self#form_view
        ~eval_context:(Form_context.incr_depth eval_context)
        (Form_view.suggest_label field_name field_view))
  in
  render_context_above self ~eval_context ~view_context @ rest
;;

let variant
      self
      ~eval_context
      ~view_context
      ({ clause_selector; selected_clause } : Form_view.variant)
  =
  let rest =
    match selected_clause with
    | None -> []
    | Some clause ->
      self#form_view
        ~eval_context:(Form_context.incr_depth eval_context)
        clause.clause_view
  in
  render_context_inline self clause_selector ~eval_context ~view_context :: rest
;;

let option self ~eval_context ~view_context ({ toggle; status } : Form_view.option_view) =
  let rest =
    match status with
    | Currently_some view | Currently_none (Some view) ->
      self#form_view ~eval_context:(Form_context.incr_depth eval_context) view
    | Currently_none None -> []
  in
  render_context_inline self toggle ~eval_context ~view_context :: rest
;;

let list
      self
      ~eval_context
      ~view_context
      ({ list_items; append_item; legacy_button_position } : Form_view.list_view)
  =
  let items_and_removals =
    List.concat_mapi list_items ~f:(fun i { item_view; remove_item } ->
      let remove_button = render_remove_item self ~eval_context remove_item ~index:i in
      Vdom.Node.tr
        [ depth_td_of_context
            eval_context
            ~extra_attrs:
              (Vdom.Attr.many
                 [ Vdom.Attr.colspan 2; Vdom.Attr.style (Css_gen.font_weight `Bold) ])
            [ remove_button ]
        ]
      :: self#form_view ~eval_context:(Form_context.incr_depth eval_context) item_view)
  in
  let append_item =
    let append_button_context =
      match list_items, legacy_button_position with
      | [], _ | _, `Inline -> eval_context
      | _, `Indented -> Form_context.incr_depth eval_context
    in
    Vdom.Node.tr
      [ depth_td_of_context
          append_button_context
          ~extra_attrs:
            (Vdom.Attr.many
               [ Vdom.Attr.colspan 2; Vdom.Attr.style (Css_gen.font_weight `Bold) ])
          [ render_append_item self ~eval_context append_item ]
      ]
  in
  render_context_above self ~view_context ~eval_context
  @ items_and_removals
  @ [ append_item ]
;;

let view self ~eval_context t =
  match t.view with
  | Empty -> self#form_empty ~eval_context ~view_context:t.context ()
  | Collapsible collapsible ->
    self#form_collapsible ~eval_context ~view_context:t.context collapsible
  | Tuple ts -> self#form_tuple ~eval_context ~view_context:t.context ts
  | Raw raw -> self#form_raw ~eval_context ~view_context:t.context raw
  | Record fields -> self#form_record ~eval_context ~view_context:t.context fields
  | Variant variant -> self#form_variant ~eval_context ~view_context:t.context variant
  | Option option -> self#form_option ~eval_context ~view_context:t.context option
  | List list -> self#form_list ~eval_context ~view_context:t.context list
;;

let to_vdom_plain self ~eval_context t =
  let rec to_vdom_plain t =
    match t.view with
    | Empty -> []
    | Collapsible { state = Collapsed None; _ } -> []
    | Collapsible { state = Collapsed (Some t); _ }
    | Collapsible { state = Expanded t; _ } -> to_vdom_plain t
    | Raw { raw_view; _ } ->
      [ raw_view t.context ~editable:(Form_context.editable eval_context) ]
    | Record fields ->
      List.concat_map fields ~f:(fun { field_view; _ } -> to_vdom_plain field_view)
    | Variant { clause_selector; selected_clause = None } -> [ clause_selector ]
    | Variant { clause_selector; selected_clause = Some { clause_view; _ } } ->
      clause_selector :: to_vdom_plain clause_view
    | Tuple ts -> List.concat_map ts ~f:to_vdom_plain
    | Option { toggle; status = Currently_none None } -> [ toggle ]
    | Option { toggle; status = Currently_none (Some t) }
    | Option { toggle; status = Currently_some t } -> toggle :: to_vdom_plain t
    | List { list_items; append_item; _ } ->
      List.concat_map list_items ~f:(fun { item_view; _ } -> to_vdom_plain item_view)
      @ [ render_append_item self ~eval_context append_item ]
  in
  to_vdom_plain t
;;

let hidden_submit_input =
  Vdom.Node.input
    ~attrs:[ Vdom.Attr.style (Css_gen.display `None); Vdom.Attr.type_ "submit" ]
    ()
;;

let to_vdom self ?on_submit ~eval_context view =
  let submit_button =
    match on_submit with
    | Some
        { on_submit
        ; handle_enter = _
        ; button_text = Some button_text
        ; button_attr
        ; button_location = _
        } ->
      [ Vdom.Node.tr
          [ depth_td'
              ~depth:0
              ~extra_attrs:(Vdom.Attr.colspan 3)
              [ (match on_submit with
                  | None ->
                    Vdom.Node.button
                      ~attrs:[ button_attr; Vdom.Attr.disabled ]
                      [ Vdom.Node.text button_text ]
                  | Some event ->
                    let event =
                      Effect.(Many [ event; Prevent_default; Stop_propagation ])
                    in
                    Vdom.Node.button
                      ~attrs:[ button_attr; Vdom.Attr.on_click (fun _ -> event) ]
                      [ Vdom.Node.text button_text ])
              ]
          ]
      ]
    | None | Some _ -> []
  in
  let inner_table =
    let form_parts =
      match Option.map on_submit ~f:(fun o -> o.button_location) with
      | None | Some `After -> self#form_view ~eval_context view @ submit_button
      | Some `Before -> submit_button @ self#form_view ~eval_context view
    in
    self#form_toplevel_combine form_parts
  in
  let inner_table =
    match Form_context.editable eval_context with
    | `Yes_always -> inner_table
    | `Currently_yes -> with_fieldset ~currently_editable:true inner_table
    | `Currently_no -> with_fieldset ~currently_editable:false inner_table
  in
  match on_submit with
  | Some { on_submit; handle_enter = true; button_text; _ } ->
    let always_use = [ Vdom.Effect.Prevent_default; Vdom.Effect.Stop_propagation ] in
    let event =
      match on_submit with
      | None -> Vdom.Effect.Many always_use
      | Some event -> Vdom.Effect.Many (event :: always_use)
    in
    Vdom.Node.create
      "form"
      ~attrs:[ Vdom.Attr.on_submit (fun _ -> event) ]
      [ inner_table
      ; (if Option.is_none button_text then hidden_submit_input else Vdom.Node.none)
      ]
  | _ -> inner_table
;;

let toplevel_combine rows = Vdom.Node.table [ Vdom.Node.tbody rows ]
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