package bonsai

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

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

(* This Id is used to identify instances of hooks.  This is so that a state-machine can
   keep all the visibility information for instances separate from one another. *)
module Id = Unique_id.Int63 ()

module Action = struct
  type action =
    | Set_visible
    | Set_hidden
    | Install
    | Remove
  [@@deriving sexp_of]

  type t = Id.t * action [@@deriving sexp_of]
end

module T = struct
  module Input = struct
    type t = Action.t -> unit Effect.t [@@deriving sexp_of]

    (* Always schedule both because we don't want one consumer to be able to
       block another from receiving an action. *)
    let combine left right action = Effect.Many [ left action; right action ]
  end

  module State = struct
    type t =
      { mutable callback : Action.action -> unit Effect.t
      ; mutable last_state : [ `Visible | `Hidden ] option
      ; observer : IntersectionObserver.intersectionObserver Js.t
      ; id : Id.t
      }
  end

  let process_entries
        (state : State.t Lazy.t)
        (entries : IntersectionObserver.intersectionObserverEntry Js.t Js.js_array Js.t)
        _observer
    =
    let state = Lazy.force state in
    Array.iter (Js.to_array entries) ~f:(fun entry ->
      let new_state = if Js.to_bool entry##.isIntersecting then `Visible else `Hidden in
      (match state.last_state, new_state with
       | Some `Visible, `Visible -> ()
       | Some `Hidden, `Hidden -> ()
       | _, `Visible ->
         Effect.Expert.handle_non_dom_event_exn (state.callback Set_visible)
       | _, `Hidden -> Effect.Expert.handle_non_dom_event_exn (state.callback Set_hidden));
      state.last_state <- Some new_state);
    ()
  ;;

  let init callback element =
    let id = Id.create () in
    let callback action = callback (id, action) in
    let rec state =
      lazy
        (let options = IntersectionObserver.empty_intersection_observer_options () in
         (* A threshold of [0, 1] means "notify me when it crosses the visible-to-hidden
            boundary" *)
         options##.threshold := Js.array [| 0.0; 1.0 |];
         let observer =
           new%js IntersectionObserver.intersectionObserver
             (Js.wrap_callback (process_entries state))
             options
         in
         observer##observe element;
         { State.callback; observer; last_state = None; id })
    in
    (* start by sending an 'install' message to our consumer *)
    Effect.Expert.handle_non_dom_event_exn (callback Install);
    Lazy.force state
  ;;

  let destroy _input (state : State.t) _element =
    state.observer##disconnect;
    (* send 'remove' message *)
    Effect.Expert.handle_non_dom_event_exn (state.callback Remove)
  ;;

  let update ~old_input ~new_input state _element =
    (* if [old_input] and [new_input] are the same, then we have nothing to do *)
    if not (phys_equal old_input new_input)
    then (
      let callback action = new_input (state.State.id, action) in
      state.callback <- callback;
      (* Our [old_input] may have had an injection function that will be expecting a
         [Remove], so we send one regardless of if it's necessary or not. *)
      Effect.Expert.handle_non_dom_event_exn (old_input (state.id, Remove));
      (* If we got a new callback input (or if we just sent a [Remove] to an existing
         consumer), we should follow up with the last state that we just saw. *)
      Effect.Expert.handle_non_dom_event_exn
        (callback
           (match state.last_state with
            | None -> Install
            | Some `Hidden -> Set_hidden
            | Some `Visible -> Set_visible)));
    ()
  ;;

  let on_mount _input _state _element = ()
end

module Hook = Vdom.Attr.Hooks.Make (T)

let attr inject = Vdom.Attr.create_hook "visibility-tracker" (Hook.create inject)

module Model = struct
  type state =
    | Installed
    | Visible
    | Hidden
  [@@deriving sexp, equal]

  type t = state Map.M(Id).t [@@deriving sexp, equal]
end

module Tracker = struct
  type t =
    | Visible
    | Hidden
    | Unknown

  let component =
    let%sub state, inject =
      Bonsai.state_machine0
        (module Model)
        (module Action)
        ~default_model:(Map.empty (module Id))
        ~apply_action:(fun ~inject:_ ~schedule_event:_ map -> function
          | id, Install -> Map.set map ~key:id ~data:Installed
          | id, Remove -> Map.remove map id
          | id, Set_visible -> Map.set map ~key:id ~data:Visible
          | id, Set_hidden -> Map.set map ~key:id ~data:Hidden)
    in
    let%sub attr = Bonsai.pure attr inject in
    let%arr attr = attr
    and state = state in
    let on_page = not (Map.is_empty state) in
    let visible =
      Map.exists state ~f:(function
        | Visible -> true
        | Installed | Hidden -> false)
    in
    let v =
      match on_page, visible with
      | false, _ -> Unknown
      | true, true -> Visible
      | true, false -> Hidden
    in
    v, attr
  ;;
end

module Vdom_model = struct
  type t = Vdom.Node.t

  let equal, sexp_of_t, t_of_sexp = phys_equal, sexp_of_opaque, opaque_of_sexp
end

let rec with_attr attr (vdom : Vdom.Node.t) =
  match vdom with
  | None ->
    (* Vdom.Node.none would cause the node to never be displayed; so we make a 0px x 0px
       div to put the attribute on instead. *)
    let style =
      Vdom.Attr.style Css_gen.(display `Inline_block @> width (`Px 0) @> height (`Px 0))
    in
    Vdom.Node.div ~attrs:[ style; attr ] []
  | Text _ -> Vdom.Node.span ~attrs:[ attr ] [ vdom ]
  | Element e ->
    Element (Vdom.Node.Element.map_attrs e ~f:(fun xs -> Vdom.Attr.many [ attr; xs ]))
  | Widget _ ->
    Vdom.Node.div
      ~attrs:[ Vdom.Attr.style (Css_gen.display `Inline_block); attr ]
      [ vdom ]
  | Lazy { key; t } -> Lazy { key; t = Lazy.map t ~f:(with_attr attr) }
;;

let only_when_visible' ?visible_attr ?hidden_attr c =
  let with_visible_attr =
    match visible_attr with
    | Some attr -> Value.map attr ~f:with_attr
    | None -> Value.return Fn.id
  in
  let with_hidden_attr =
    match hidden_attr with
    | Some attr -> Value.map attr ~f:with_attr
    | None -> Value.return Fn.id
  in
  let%sub state, attr = Tracker.component in
  let%sub prev_vdom, set_prev_vdom = Bonsai.state_opt (module Vdom_model) in
  let%sub vdom_and_other =
    match%sub Value.both state prev_vdom with
    (* Always render the component at least once, so even in the None case,
       we render it; this will grab the vdom for the next frame, in which we'll
       probably fall through to the other branch. *)
    | _, None | Visible, _ ->
      let%sub vdom, other = c in
      let%sub () =
        Bonsai.Edge.on_change
          (module Vdom_model)
          vdom
          ~callback:
            (let%map set_prev_vdom = set_prev_vdom in
             fun v -> set_prev_vdom (Some v))
      in
      let%arr vdom = vdom
      and other = other
      and with_visible_attr = with_visible_attr in
      with_visible_attr vdom, Some other
    | (Unknown | Hidden), Some prev_vdom ->
      let%arr prev_vdom = prev_vdom
      and with_hidden_attr = with_hidden_attr in
      with_hidden_attr prev_vdom, None
  in
  let%arr vdom, other = vdom_and_other
  and attr = attr in
  with_attr attr vdom, other
;;

let only_when_visible ?visible_attr ?hidden_attr c =
  let c = Computation.map c ~f:(fun vdom -> vdom, ()) in
  let%sub vdom, _ = only_when_visible' ?visible_attr ?hidden_attr c in
  return vdom
;;
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