package bonsai

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

Source file form_automatic.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
open! Core
open (Bonsai_web : module type of Bonsai_web with module View := Bonsai_web.View)
open Bonsai.Let_syntax
open Form_manual
module View = View_automatic

module T = struct
  type nonrec 'a t = ('a, View.t) Form_manual.t

  let value t = t.value
  let view t = t.view
  let set t = t.set
  let create ~value ~view ~set = { value; view; set }
  let value_or_default t ~default = t |> value |> Or_error.ok |> Option.value ~default

  let normalize { value; set; view = _ } =
    match value with
    | Ok value -> set value
    | Error _ -> Ui_effect.Ignore
  ;;
end

include T

module Submit = struct
  type 'a t =
    { f : 'a -> unit Ui_effect.t
    ; handle_enter : bool
    ; button_text : string option
    ; button_attr : Vdom.Attr.t
    ; button_location : View.button_location
    }

  let create
    ?(handle_enter = true)
    ?(button = Some "submit")
    ?(button_attr = Vdom.Attr.empty)
    ?(button_location = `After)
    ~f
    ()
    =
    { f; handle_enter; button_text = button; button_attr; button_location }
  ;;
end

let view_as_vdom ?theme ?on_submit ?editable t =
  let on_submit =
    Option.map
      on_submit
      ~f:(fun { Submit.f; handle_enter; button_text; button_attr; button_location } ->
      { View.on_submit = Option.map ~f (Or_error.ok t.value)
      ; handle_enter
      ; button_text
      ; button_attr
      ; button_location
      })
  in
  View.to_vdom ?theme ?on_submit ?editable t.view
;;

let label' label t = { t with view = View.set_label label t.view }
let label text = label' (Vdom.Node.text text)
let tooltip' tooltip t = { t with view = View.set_tooltip tooltip t.view }
let tooltip text = tooltip' (Vdom.Node.text text)

module For_profunctor = struct
  type ('read, 'write) unbalanced =
    { value : 'read Or_error.t
    ; view : View.t
    ; set : 'write -> unit Vdom.Effect.t
    }

  let unbalanced_of_t ({ value; view; set } : _ t) : _ unbalanced = { value; view; set }

  type ('read, 'write) t =
    | Return :
        { name : string
        ; form : ('read, 'write) unbalanced
        }
        -> ('read, 'write) t
    | Both : ('a, 'write) t * ('b, 'write) t -> ('a * 'b, 'write) t
    | Map : ('a, 'write) t * ('a -> 'b) -> ('b, 'write) t
    | Contra_map : ('read, 'a) t * ('b -> 'a) -> ('read, 'b) t

  let both a b = Both (a, b)
  let map a ~f = Map (a, f)
  let contra_map a ~f = Contra_map (a, f)

  let rec finalize_view
    : type read write.
      (read, write) t -> read Or_error.t * (write -> unit Effect.t) * View.field list
    = function
    | Return { name; form } ->
      form.value, form.set, [ { View.field_name = name; field_view = form.view } ]
    | Map (form, f) ->
      let value, set, fields = finalize_view form in
      Or_error.map value ~f, set, fields
    | Contra_map (form, g) ->
      let value, set, fields = finalize_view form in
      value, (fun x -> Effect.lazy_ (lazy (set (g x)))), fields
    | Both (a, b) ->
      let a_value, a_set, a_fields = finalize_view a in
      let b_value, b_set, b_fields = finalize_view b in
      let value = Or_error.both a_value b_value in
      let set t = Effect.lazy_ (lazy (Effect.Many [ a_set t; b_set t ])) in
      let fields = a_fields @ b_fields in
      value, set, fields
  ;;
end

module Record_builder = struct
  include Profunctor.Record_builder (For_profunctor)

  let label_of_field fieldslib_field =
    fieldslib_field
    |> Fieldslib.Field.name
    |> String.map ~f:(function
         | '_' -> ' '
         | other -> other)
  ;;

  let attach_fieldname_to_error t fieldslib_field =
    Result.map_error
      t.value
      ~f:(Error.tag ~tag:(sprintf "in field %s" (Fieldslib.Field.name fieldslib_field)))
  ;;

  (* This function "overrides" the [field] function inside of Record_builder
     by adding a label *)
  let field' t ~label_of_field fieldslib_field =
    let value = attach_fieldname_to_error t fieldslib_field in
    let with_label =
      For_profunctor.Return
        { name = label_of_field fieldslib_field
        ; form = { (For_profunctor.unbalanced_of_t t) with value }
        }
    in
    field with_label fieldslib_field
  ;;

  let field = field' ~label_of_field

  let build_for_record a =
    let value, set, fields = For_profunctor.finalize_view (build_for_record a) in
    { value; set; view = View.record fields }
  ;;
end

module Expert = struct
  let create = create
end

include Form_manual

module Dynamic = struct
  include Dynamic

  let error_hint t =
    let%arr t = t in
    match Result.error t.value with
    | Some err -> { t with view = View.suggest_error err t.view }
    | None -> t
  ;;

  let collapsible_group ?(starts_open = true) label t =
    let%sub open_state = Bonsai.toggle ~default_model:starts_open in
    let%arr is_open, toggle_is_open = open_state
    and label = label
    and t = t in
    let label =
      Vdom.Node.div
        ~attrs:
          [ Vdom.Attr.on_click (fun _ -> toggle_is_open)
          ; Vdom.Attr.style
              Css_gen.(
                user_select `None @> Css_gen.create ~field:"cursor" ~value:"pointer")
          ]
        [ Vdom.Node.text (if is_open then "▾ " ^ label else "► " ^ label) ]
    in
    let view =
      match is_open with
      | false -> View.collapsible ~label ~state:(Collapsed None)
      | true -> View.collapsible ~label ~state:(Expanded t.view)
    in
    { t with view }
  ;;

  module Record_builder = struct
    include Profunctor.Record_builder (struct
      type ('read, 'write) t = ('read, 'write) For_profunctor.t Value.t

      let both a b = Value.map2 a b ~f:For_profunctor.both
      let map a ~f = Value.map a ~f:(For_profunctor.map ~f)
      let contra_map a ~f = Value.map a ~f:(For_profunctor.contra_map ~f)
    end)

    let field' t ~label_of_field fieldslib_field =
      let for_profunctor =
        let%map t = t in
        let t =
          { t with value = Record_builder.attach_fieldname_to_error t fieldslib_field }
        in
        For_profunctor.Return
          { name = label_of_field fieldslib_field
          ; form = For_profunctor.unbalanced_of_t t
          }
      in
      field for_profunctor fieldslib_field
    ;;

    let field = field' ~label_of_field:Record_builder.label_of_field

    let build_for_record creator =
      let%arr t = build_for_record creator in
      let value, set, fields = For_profunctor.finalize_view t in
      { value; set; view = View.record fields }
    ;;
  end
end

module Private = struct
  let suggest_label label t =
    { t with view = View.suggest_label' (Vdom.Node.text label) t.view }
  ;;
end

include T

let to_form2 form = map_view form ~f:(fun old_view -> View.to_vdom old_view)

let to_form2' form =
  let%arr form = form in
  to_form2 form
;;

let of_form2 form2 =
  let%sub path = Bonsai.path_id in
  let%arr form2 = form2
  and path = path in
  map_view form2 ~f:(fun old_view -> View.of_vdom old_view ~unique_key:path)
;;

let return ?sexp_of_t ?equal value =
  map_view (return ?sexp_of_t ?equal value) ~f:(fun () -> View.empty)
;;

let return_settable ?sexp_of_model ~equal value =
  let%sub form = return_settable ?sexp_of_model ~equal value in
  let%arr form = form in
  map_view form ~f:(fun () -> View.empty)
;;

let return_error error = map_view (return_error error) ~f:(fun () -> View.empty)
let both a b = map_view (both a b) ~f:(fun (a, b) -> View.tuple [ a; b ])
let all forms = map_view (all forms) ~f:View.tuple
let all_map forms = map_view (all_map forms) ~f:(fun views -> View.tuple (Map.data views))
let project form ~parse_exn ~unparse = project form ~parse_exn ~unparse
let project' form ~parse ~unparse = project' form ~parse ~unparse
let validate form ~f = validate form ~f