package bonsai

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

Source file bonsai_web_ui_popover.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
open! Core
open Bonsai_web
open Bonsai.Let_syntax
open Js_of_ocaml

module Result = struct
  type t =
    { wrap : Vdom.Node.t -> Vdom.Node.t
    ; open_ : unit Effect.t
    ; close : unit Effect.t
    ; toggle : unit Effect.t
    ; is_open : bool
    }
end

module Direction = struct
  type t =
    | Left
    | Right
    | Down
    | Up
end

module Alignment = struct
  type t =
    | Start
    | Center
    | End
end

let direction_to_attr = function
  | Direction.Down -> Style.bottom
  | Up -> Style.top
  | Left -> Style.left
  | Right -> Style.right
;;

let alignment_to_attr = function
  | Alignment.Start -> Style.align_start
  | Center -> Vdom.Attr.empty
  | End -> Style.align_end
;;

let has_clicked_outside : popover_id:string -> Dom.node Js.t Js.opt -> bool =
  fun ~popover_id element ->
  let rec loop : Dom.node Js.t Js.opt -> bool =
    fun element ->
      match Js.Opt.to_option element with
      | None -> true
      | Some element ->
        (match Dom.nodeType element with
         | Attr _ | Text _ | Other _ -> loop element##.parentNode
         | Element element ->
           (match Js.Opt.to_option (element##getAttribute (Js.string "id")) with
            | None -> loop element##.parentNode
            | Some id ->
              if String.equal (Js.to_string id) popover_id
              then false
              else loop element##.parentNode))
  in
  loop element
;;


let default_popover_styles =
  let%sub theme = View.Theme.current in
  let%arr theme = theme in
  let constants = View.constants theme in
  let vars =
    Style.Variables.set
      ~bg:(Css_gen.Color.to_string_css constants.extreme.background)
      ~fg:(Css_gen.Color.to_string_css constants.extreme.foreground)
      ~border:(Css_gen.Color.to_string_css constants.extreme_primary_border)
      ()
  in
  Vdom.Attr.many [ vars; Style.default_tooltip_styles ]
;;

let component
      ?popover_extra_attr
      ?popover_style_attr
      ?(allow_event_propagation_when_clicked_outside :
          ([ `Left_click | `Right_click | `Escape ] -> bool) Value.t =
          Value.return (fun _ -> false))
      ?(on_close = Value.return Effect.Ignore)
      ~close_when_clicked_outside
      ~direction
      ~alignment
      ~popover
      ()
  =
  let%sub popover_id = Bonsai.path_id in
  let%sub popover_extra_attr =
    Option.value_map popover_extra_attr ~default:(Bonsai.const Vdom.Attr.empty) ~f:return
  in
  let%sub popover_style_attr =
    Option.value_map popover_style_attr ~default:default_popover_styles ~f:return
  in
  let%sub { state = is_open; set_state = set_is_open; toggle } =
    Bonsai.toggle' ~default_model:false
  in
  let%sub direction_class =
    let%arr direction = direction in
    direction_to_attr direction
  in
  let%sub alignment_class =
    let%arr alignment = alignment in
    alignment_to_attr alignment
  in
  let%sub open_, close =
    let%arr set_is_open = set_is_open
    and on_close = on_close in
    set_is_open true, Effect.Many [ set_is_open false; on_close ]
  in
  let%sub popover =
    match%sub is_open with
    | false -> Bonsai.const Vdom.Node.none
    | true ->
      let%sub outside_click_listener_attr =
        match close_when_clicked_outside with
        | false -> Bonsai.const Vdom.Attr.empty
        | true ->
          let%arr close = close
          and popover_id = popover_id
          and allow_event_propagation_when_clicked_outside =
            allow_event_propagation_when_clicked_outside
          in
          let f ~source event =
            let target = (event##.target :> Dom.node Js.t Js.opt) in
            match has_clicked_outside ~popover_id target with
            | true ->
              let should_block =
                not (allow_event_propagation_when_clicked_outside source)
              in
              (match should_block with
               | false -> close
               | true ->
                 Effect.Many
                   [ close
                   ; Effect.Stop_propagation
                   (* Prevents other listeners/from trigerring their events. *)
                   ; Effect.Prevent_default
                     (* Prevents non-event interactions like context menus from opening
                        and interactions with form elements + clicking on links. *)
                   ])
            | false -> Effect.Ignore
          in
          let handle_if_escape event =
            match Dom_html.Keyboard_code.of_event event with
            | Escape -> f ~source:`Escape event
            | _ -> Effect.Ignore
          in
          Vdom.Attr.many
            [ Vdom.Attr.Global_listeners.click (f ~source:`Left_click)
            ; Vdom.Attr.Global_listeners.contextmenu (f ~source:`Right_click)
            ; Vdom.Attr.Global_listeners.keydown handle_if_escape
            ]
      in
      let%sub popover = popover ~close in
      let%arr popover = popover
      and popover_id = popover_id
      and outside_click_listener_attr = outside_click_listener_attr
      and popover_extra_attr = popover_extra_attr
      and popover_style_attr = popover_style_attr in
      Vdom.Node.div
        ~attrs:
          [ Style.tooltip
          ; Vdom.Attr.id popover_id
          ; popover_style_attr
          ; popover_extra_attr
          ; outside_click_listener_attr
          ]
        [ popover ]
  in
  let%sub open_attr =
    match%arr is_open with
    | false -> Vdom.Attr.empty
    | true -> Style.tooltip_open
  in
  let%sub wrap =
    let%arr popover = popover
    and direction_class = direction_class
    and alignment_class = alignment_class
    and open_attr = open_attr in
    fun popover_base ->
      Vdom.Node.span
        ~attrs:[ Style.tooltip_container; open_attr; direction_class; alignment_class ]
        [ popover_base; popover ]
  in
  let%arr open_ = open_
  and close = close
  and wrap = wrap
  and toggle = toggle
  and is_open = is_open in
  { Result.wrap; open_; close; toggle; is_open }
;;
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