package virtual_dom_toplayer

  1. Overview
  2. Docs

Source file 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
open! Core
open Virtual_dom
open Floating_positioning_new

module Show_on_mount = Vdom.Attr.Hooks.Make (struct
  module State = Unit

  module Input = struct
    type t = unit [@@deriving sexp, equal]

    let combine () () = ()
  end

  let init () _elem = ()
  let on_mount () () elem = Popover_dom.show_popover elem
  let on_mount = `Schedule_animation_frame on_mount
  let update ~old_input:() ~new_input:() () _elem = ()
  let destroy () () _ = ()
end)

let show_on_mount =
  Show_on_mount.create () |> Vdom.Attr.create_hook "vdom_toplayer_show_on_mount"
;;

module Popover_attr = struct
  module Impl = struct
    module Input = struct
      module For_one = struct
        type t =
          { content : Vdom_with_phys_equal.t
          ; arrow : Vdom_with_phys_equal.t option
          ; position : Position.t
          ; alignment : Alignment.t
          ; offset : Offset.t
          }
        [@@deriving sexp_of, equal]

        let equal a b = phys_equal a b || equal a b
      end

      type t = For_one.t list [@@deriving sexp_of, equal]

      let combine a b = a @ b
    end

    module State = struct
      module For_one = struct
        type t =
          { portal : Portal.t
          ; input : Input.For_one.t
          }
      end

      type t = For_one.t list ref
    end

    let wrap_content { Input.For_one.position; alignment; offset; content; arrow } ~anchor
      =
      let position_attr =
        Floating_positioning_new.position_me
          ~arrow_selector:Popover_dom.arrow_selector
          ~position
          ~alignment
          ~offset
          (Floating_positioning_new.Anchor.of_element anchor)
      in
      Popover_dom.node
        ?arrow
        ~extra_attrs:[ position_attr; show_on_mount ]
        ~kind:`Manual
        content
    ;;

    let create_one (input : Input.For_one.t) ~anchor =
      let portal_root = Portal.For_popovers.find_popover_portal_root anchor in
      let portal = Portal.create portal_root (wrap_content input ~anchor) in
      { State.For_one.portal; input }
    ;;

    let update_one input (state : State.For_one.t) ~anchor =
      match Input.For_one.equal input state.input with
      | true -> state
      | false ->
        Portal.apply_patch state.portal (wrap_content input ~anchor);
        { state with input }
    ;;

    let destroy_one { State.For_one.portal; input = _ } = Portal.destroy portal
    let init _ _ = ref []

    let on_mount all_inputs state_ref anchor =
      let state = List.map all_inputs ~f:(create_one ~anchor) in
      state_ref := state
    ;;

    let on_mount = `Schedule_animation_frame on_mount

    let update ~old_input ~(new_input : Input.t) (state_ref : State.t) anchor =
      match phys_equal old_input new_input with
      | true -> ()
      | false ->
        let zipped, remainder = List.zip_with_remainder new_input !state_ref in
        let updated_state =
          List.map zipped ~f:(fun (input, state) -> update_one input state ~anchor)
        in
        let state_from_remainder =
          match remainder with
          | None -> []
          | Some (Second old_states) ->
            List.iter old_states ~f:destroy_one;
            []
          | Some (First new_inputs) -> List.map new_inputs ~f:(create_one ~anchor)
        in
        state_ref := updated_state @ state_from_remainder
    ;;

    let destroy _ (state : State.t) _ = List.iter !state ~f:destroy_one
  end

  include Impl
  include Vdom.Attr.Hooks.Make (Impl)
end

let attr
  ?(position = Position.Auto)
  ?(alignment = Alignment.Center)
  ?(offset = Offset.zero)
  ?arrow
  content
  =
  Popover_attr.create [ { position; alignment; offset; content; arrow } ]
  |> Vdom.Attr.create_hook [%string "vdom_toplayer"]
;;

let node
  ?(position = Position.Auto)
  ?(alignment = Alignment.Center)
  ?(offset = Offset.zero)
  ?arrow
  ~popover_content
  anchor
  =
  Popover_dom.node
    ?arrow
    ~kind:`Manual
    ~extra_attrs:
      [ show_on_mount
      ; position_me
          ~arrow_selector:Popover_dom.arrow_selector
          ~position
          ~alignment
          ~offset
          anchor
      ]
    popover_content
;;