package bonsai

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

Source file render_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
open! Core
open Bonsai_web
module Attr = Vdom.Attr
module Form = Bonsai_web_ui_form
module Node = Vdom.Node
module Form_view = Form.View

module Tooltip = struct
  module Style =
    [%css
      stylesheet
        {|
        .container {
          position: relative;
          display: inline-block;
        }
        .content {
          white-space: pre-line;
          visibility: hidden;
          width: 300px;
          background-color: beige;
          text-align: center;
          border-radius: 3px;
          padding: 0.5em 1em 0.5em 1em;
          border: 1px solid black;
          position: absolute;
          z-index: 1;
          left: 100%;
          cursor: text;
        }
        .container:hover .content {
          visibility: visible;
        }
 |}]

  let wrap ?tooltip_element ~attr children =
    Node.div
      ~attrs:[ Attr.(Style.container @ attr) ]
      [ children
      ; (match tooltip_element with
         | None -> Node.none
         | Some element -> Node.div ~attrs:[ Style.content ] [ element ])
      ]
  ;;
end

module Style =
  [%css
    stylesheet
      ~rewrite:
        [ "--font-family", "--font-family"
        ; "--font-size", "--font-size"
        ; "--accent-h", "--accent-h"
        ; "--accent-s", "--accent-s"
        ; "--accent-l", "--accent-l"
        ]
      {|
      .form {
        --font-size: 12px;
        --font-family: monospace;
        font-family: var(--font-family);
        font-size: var(--font-size);
      }

      .form table {
        width: 100%;
      }
      .form input,.form select, .form textarea {
        font-family: var(--font-family);
        font-size: var(--font-size);
        border:none;
        border-bottom:1px solid gray;
        padding-bottom:1px;
        width:100%;
        background-color:inherit;
      }
      .form input, .form textarea {
        min-width:250px;
      }
      .form textarea {
        height:1.4em;
        resize:none;
      }
      .form textarea:hover {
        resize:both;
      }
      .form select {
        min-width:100px;
      }
      .form input:focus-visible,.form select:focus-visible {
        outline:none;
        border:none;
        border-bottom:2px solid black;
        padding-bottom:0px;
      }
      .form button {
        font-family: var(--font-family);
        font-size: var(--font-size);
        cursor: pointer;
        color: blue;
        background: none;
        padding-top: 0.1rem;
        padding-bottom: 0.1rem;
      }
      .form button:hover, .form button:focus-visible {
        border-bottom: 1px solid blue !important;
        margin-bottom: -1px;
      }
      fieldset[disabled] .form button {
        display:none;
      }
      .label {
        font-weight:bold;
        padding-right: 2px;
        text-align: left;
        user-select: none;
        white-space: nowrap;
        display: flex;
        justify-content: space-between;
      }
      .label_error {
        text-decoration: underline wavy red;
        cursor: pointer;
      }
      .label_info {
        cursor: pointer;
      }
      .label_info::after {
        content:"";
        width: 0;
        height: 0;
        border-style: solid;
        border-width: 0 6px 6px 0;
        border-color: transparent #007bff transparent transparent;
        display:block;
      }
      .clear_fieldset_styles {
        border: 0;
        margin: 0;
        padding: 0;
      }
      .mod_depth_1 {
        --accent-h:0;
        --accent-s:81%;
        --accent-l:54%;
      }
      .mod_depth_2 {
        --accent-h:209;
        --accent-s:100%;
        --accent-l:50%;
      }
      .mod_depth_3 {
        --accent-h:137;
        --accent-s:100%;
        --accent-l:36%;
      }
      .mod_depth_4 {
        --accent-h:32;
        --accent-s:100%;
        --accent-l:49%;
      }
      .nested_table {
        padding-left:1.3rem;
        border-width: 0 0 0 1px;
        border-color: hsla(var(--accent-h), var(--accent-s), var(--accent-l), 1);
        border-style: solid;
        background-color: hsla(var(--accent-h), var(--accent-s), 95%, 1);
      }
      .nested_table:hover {
        border-width: 0 0 0 2px;
        margin-left: -1px;
      }
|}]

(* These CSS rules are used to clear user-agent styles. We use :where
   to decrease specificity (otherwise child elements would not be able to
   easily set the same properties with their own classes)

   We need to append the CSS because [ppx_css] does not mangle classes in the pseudo
   selector*)
let () =
  let form = Style.For_referencing.form in
  Inline_css.Private.append
    [%string
      {|
      :where(.%{form}) *,
      :where(.%{form}) *::before,
      :where(.%{form}) *::after {
        cursor:pointer;
        box-sizing: border-box;
        margin: 0;
        padding: 0;
        border: none;
        outline: none;
      }
|}]
;;

let nested_table_depth_classes =
  Style.[ mod_depth_1; mod_depth_2; mod_depth_3; mod_depth_4 ]
;;

let nested_table eval_context children =
  let table_attr =
    Attr.many
      [ List.nth_exn
          nested_table_depth_classes
          (View.Expert.Form_context.depth eval_context
           mod List.length nested_table_depth_classes)
      ; Style.nested_table
      ]
  in
  Node.tr
    [ Node.td ~attrs:[ Attr.colspan 100 ] [ Node.table ~attrs:[ table_attr ] children ] ]
;;

let label_wrapper ?(attr = Attr.empty) (context : Form_view.context) =
  let error =
    Option.map context.error ~f:(fun error -> Node.text (Error.to_string_hum error))
  in
  let label = Option.value context.label ~default:(Node.text "") in
  let label_classes =
    List.filter_opt
      [ Some Style.label
      ; Option.some_if (Option.is_some context.error) Style.label_error
      ; Option.some_if (Option.is_some context.tooltip) Style.label_info
      ]
  in
  let tooltip_element =
    match List.filter_opt [ error; context.tooltip ] with
    | [] -> None
    | elements -> Some (Node.div (List.intersperse elements ~sep:(Node.hr ())))
  in
  Node.td [ Tooltip.wrap ?tooltip_element ~attr:Attr.(many label_classes @ attr) label ]
;;

let header_is_inhabited view_context =
  Option.is_some view_context.Form_view.label
  || Option.is_some view_context.tooltip
  || Option.is_some view_context.error
;;

let with_auto_generated_forms ~theme =
  let module Form_context = View.Expert.Form_context in
  View.Expert.override_theme theme ~f:(fun (module M) ->
    (module struct
      class c =
        object (self)
          inherit M.c
          method! theme_name = "Bonsai_web_ui_auto_generated"

          method! form_tuple ~eval_context ~view_context ts =
            let header_is_inhabited = header_is_inhabited view_context in
            let eval_context =
              if header_is_inhabited
              then Form_context.incr_depth eval_context
              else eval_context
            in
            let rest = List.concat_map ts ~f:(self#form_view ~eval_context) in
            if header_is_inhabited
            then (
              let label = label_wrapper ~attr:Attr.(colspan 2) view_context in
              [ Node.tr [ label ]; nested_table eval_context rest ])
            else rest

          method! form_raw ~eval_context ~view_context ({ id; raw_view } : Form_view.raw)
            =
            let view_context =
              { view_context with
                label =
                  Option.map view_context.label ~f:(fun label ->
                    Node.label
                      ~attrs:[ Attr.for_ id; Attr.style (Css_gen.display `Block) ]
                      [ label ])
              }
            in
            [ Node.tr
                ~key:id
                [ label_wrapper view_context
                ; Node.td
                    [ raw_view view_context ~editable:(Form_context.editable eval_context)
                    ]
                ]
            ]

          method! form_record ~eval_context ~view_context fields =
            let header_is_inhabited = header_is_inhabited view_context in
            let eval_context =
              if header_is_inhabited
              then Form_context.incr_depth eval_context
              else eval_context
            in
            let rest =
              List.concat_map fields ~f:(fun { field_name; field_view } ->
                self#form_view
                  ~eval_context
                  (Form_view.suggest_label field_name field_view))
            in
            if header_is_inhabited
            then (
              let label = label_wrapper ~attr:Attr.(colspan 2) view_context in
              [ Node.tr [ label ]; nested_table eval_context rest ])
            else rest

          method! form_variant
                  ~eval_context
                  ~view_context
                  ({ clause_selector; selected_clause } : Form_view.variant) =
            let eval_context = Form_context.incr_depth eval_context in
            let rest =
              match selected_clause with
              | None -> []
              | Some { clause_name = _; clause_view } ->
                self#form_view ~eval_context clause_view
            in
            let label = label_wrapper view_context in
            [ Node.tr [ label; Node.td [ clause_selector ] ]
            ; nested_table eval_context rest
            ]

          method! form_option
                  ~eval_context
                  ~view_context
                  ({ toggle; status } : Form_view.option_view) =
            let eval_context = Form_context.incr_depth eval_context in
            let rest =
              match status with
              | Currently_none None -> []
              | Currently_some t | Currently_none (Some t) ->
                self#form_view ~eval_context t
            in
            let label = label_wrapper view_context in
            [ Node.tr [ label; Node.td [ toggle ] ]; nested_table eval_context rest ]

          method! form_list
                  ~eval_context
                  ~view_context
                  ({ list_items; append_item; legacy_button_position = _ } :
                     Form_view.list_view) =
            let header_is_inhabited = header_is_inhabited view_context in
            let eval_context =
              if header_is_inhabited
              then Form_context.incr_depth eval_context
              else eval_context
            in
            let rest =
              let items_and_removals =
                List.concat_mapi list_items ~f:(fun i { item_view; remove_item } ->
                  let eval_context = Form_context.incr_depth eval_context in
                  let rest = self#form_view ~eval_context item_view in
                  let remove_button =
                    self#form_remove_item ~eval_context remove_item ~index:i
                  in
                  [ Node.tr
                      [ Node.td
                          ~attrs:
                            [ Attr.colspan 2; Attr.style (Css_gen.font_weight `Bold) ]
                          [ remove_button ]
                      ]
                  ; nested_table eval_context rest
                  ])
              in
              let append_item =
                Node.tr
                  [ Node.td
                      ~attrs:[ Vdom.Attr.colspan 2; Style.label ]
                      [ self#form_append_item ~eval_context append_item ]
                  ]
              in
              items_and_removals @ [ append_item ]
            in
            if header_is_inhabited
            then (
              let label = label_wrapper ~attr:Attr.(colspan 2) view_context in
              [ Node.tr [ label ]; nested_table eval_context rest ])
            else rest

          method! form_toplevel_combine rows =
            Node.table ~attrs:[ Style.form ] [ Node.tbody rows ]
        end
    end))
;;

let to_vdom ?(theme = View.Expert.default_theme) ?on_submit ?editable view =
  Vdom.Node.lazy_
    (lazy
      (Form.View.to_vdom
         ?on_submit
         ?editable
         view
         ~theme:(with_auto_generated_forms ~theme)))
;;
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