package incr_select

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

Source file incr_select.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
open Core

module Make (Incr : Incremental.S_gen) = struct
  module E = Incr.Expert

  (* Hashtbl starts out at a ridiculous size of 128. This is a more reasonable number
     of bins to have. *)
  let hashtbl_size = 10

  (** [setup_generator] sets up the staged conversion.

      [hashable] is used to build a table of necessary dependencies. We drop unnecessary
      dependencies to allow them to be collected.

      [compute_output key] returns the value of the output node corresponding to [key].
      [compute_output] is closed over the mutable state determining the current value of
      the selector's input.

      [make_input_node] makes sure that when the mutable state inside [compute_output] is
      updated, the corresponding nodes in the [necessary_dependencies] table are made
      stale.  *)
  let setup_generator
    (hashable : 'a Hashtbl_intf.Hashable.t)
    ~(compute_output : 'a -> 'b)
    ~(make_input_node : make_key_stale:('a -> unit) -> unit Incr.t)
    : ('a -> 'b Incr.t) Staged.t
    =
    let necessary_dependencies =
      Hashtbl.Using_hashable.create ~size:hashtbl_size ~hashable ()
    in
    let (input_node : unit Incr.t) =
      let make_key_stale key =
        Hashtbl.find necessary_dependencies key
        |> Option.value ~default:[]
        |> List.iter ~f:E.Node.make_stale
      in
      make_input_node ~make_key_stale
    in
    (* Set the cutoff so that we never pass automatically from the update to the nodes. We
       want everything to go through [make_key_stale] *)
    Incr.set_cutoff input_node Incr.Cutoff.always;
    stage (fun key ->
      let input_dep = E.Dependency.create input_node in
      let rec output_node =
        lazy
          (E.Node.create
             (fun () -> compute_output key)
             ~on_observability_change:(fun ~is_now_observable ->
               if is_now_observable
               then
                 Hashtbl.add_multi necessary_dependencies ~key ~data:(force output_node)
               else
                 Hashtbl.change necessary_dependencies key ~f:(function
                   | None -> None
                   | Some l ->
                     (match
                        List.filter l ~f:(Fn.non (phys_equal (force output_node)))
                      with
                      | [] -> None
                      | l' -> Some l'))))
      in
      let output_node = force output_node in
      E.Node.add_dependency output_node input_dep;
      E.Node.watch output_node)
  ;;

  (** This creates a unit incremental that fires whenever the input incremental
      fires. When that occurs, it updates [selected] to match the current value of
      [input], and calls [make_key_stale] for both the old and new value of the
      incremental. *)
  let update_one ~input ~selected ~make_stale =
    Incr.map input ~f:(fun inp ->
      Option.iter inp ~f:make_stale;
      Option.iter !selected ~f:make_stale;
      selected := inp)
  ;;

  let select_one'
    (type a)
    (module H : Hashable.Common with type t = a)
    (input : a option Incr.t)
    =
    let selected = ref None in
    let compute_output key =
      match !selected with
      | None -> false
      | Some key' -> H.compare key key' = 0
    in
    let make_input_node ~make_key_stale =
      update_one ~input ~selected ~make_stale:make_key_stale
    in
    setup_generator H.hashable ~compute_output ~make_input_node
  ;;

  let select_one h input = select_one' h (Incr.map ~f:Option.some input)

  let select_one_value'
    (type a)
    (module H : Hashable.Common with type t = a)
    ~default
    input
    =
    let selected = ref None in
    let compute_output key =
      match !selected with
      | None -> default
      | Some (key', data) -> if H.compare key key' = 0 then data else default
    in
    let make_input_node ~make_key_stale =
      update_one ~selected ~input ~make_stale:(fun (key, _) -> make_key_stale key)
    in
    setup_generator H.hashable ~compute_output ~make_input_node
  ;;

  let select_one_value h ~default input =
    select_one_value' h ~default (Incr.map ~f:Option.some input)
  ;;

  let select_many_values
    (type a)
    (module H : Hashable.Common with type t = a)
    ~default
    input
    =
    let hashable = H.hashable in
    let selected = Hashtbl.Using_hashable.create ~size:hashtbl_size ~hashable () in
    let compute_output key = Hashtbl.find selected key |> Option.value ~default in
    let make_input_node ~make_key_stale =
      Incr.map input ~f:(fun inp ->
        Hashtbl.iter_keys selected ~f:make_key_stale;
        Hashtbl.clear selected;
        List.iter inp ~f:(fun (key, data) ->
          make_key_stale key;
          Hashtbl.set selected ~key ~data))
    in
    setup_generator hashable ~compute_output ~make_input_node
  ;;

  let select_many (type a) (module H : Hashable.Common with type t = a) input =
    let hashable = H.hashable in
    let selected = Hash_set.Using_hashable.create ~size:hashtbl_size ~hashable () in
    let compute_output key = Hash_set.mem selected key in
    let make_input_node ~make_key_stale =
      Incr.map input ~f:(fun inp ->
        let old_set = Hash_set.copy selected in
        Hash_set.clear selected;
        List.iter inp ~f:(fun key ->
          if not (Hash_set.mem old_set key) then make_key_stale key;
          Hash_set.add selected key);
        Hash_set.iter old_set ~f:(fun key ->
          if not (Hash_set.mem selected key) then make_key_stale key))
    in
    setup_generator hashable ~compute_output ~make_input_node
  ;;
end
OCaml

Innovation. Community. Security.