package core

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

Source file hash_queue.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
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
open! Import
open Hash_queue_intf

module type Key = Key
module type S_backend = S_backend

module Make_backend (Table : Hashtbl_intf.Hashtbl) : S_backend = struct
  module type Backend =
    S1
    with type 'key create_arg := 'key Hashtbl.Hashable.t
    with type 'key create_key := 'key

  module Backend : Backend = struct
    module Key_value = struct
      module T = struct
        type ('key, 'value) t =
          { key : 'key
          ; mutable value : 'value
          }
      end

      include T

      let key t = t.key
      let value t = t.value

      let sexp_of_t sexp_of_key sexp_of_data { key; value } =
        [%sexp_of: key * data] (key, value)
      ;;
    end

    open Key_value.T
    module Elt = Doubly_linked.Elt

    type ('key, 'data) t =
      { mutable num_readers : int
      ; queue : ('key, 'data) Key_value.t Doubly_linked.t
      ; table : ('key, ('key, 'data) Key_value.t Elt.t) Table.t
      }

    let sexp_of_t sexp_of_key sexp_of_data t =
      [%sexp_of: (key, data) Key_value.t Doubly_linked.t] t.queue
    ;;

    let invariant t =
      assert (Doubly_linked.length t.queue = Table.length t.table);
      (* Look at each element in the queue, checking:
       *   - every element in the queue is in the hash table
       *   - there are no duplicate keys
      *)
      let keys = Table.create ~size:(Table.length t.table) (Table.hashable_s t.table) in
      Doubly_linked.iter t.queue ~f:(fun kv ->
        let key = kv.key in
        match Table.find t.table key with
        | None -> assert false
        | Some _ ->
          assert (not (Table.mem keys key));
          Table.set keys ~key ~data:())
    ;;

    let create ?(growth_allowed = true) ?(size = 16) hashable =
      { num_readers = 0
      ; queue = Doubly_linked.create ()
      ; table = Table.create ~growth_allowed ~size (Table.Hashable.to_key hashable)
      }
    ;;

    let read t f =
      t.num_readers <- t.num_readers + 1;
      Exn.protect ~f ~finally:(fun () -> t.num_readers <- t.num_readers - 1)
    ;;

    let ensure_can_modify t =
      if t.num_readers > 0
      then failwith "It is an error to modify a Hash_queue.t while iterating over it."
    ;;

    let clear t =
      ensure_can_modify t;
      Doubly_linked.clear t.queue;
      Table.clear t.table
    ;;

    let length t = Table.length t.table
    let is_empty t = length t = 0

    let lookup t k =
      match Table.find t.table k with
      | None -> None
      | Some elt -> Some (Elt.value elt).value
    ;;

    let lookup_exn t k = (Elt.value (Table.find_exn t.table k)).value
    let mem t k = Table.mem t.table k

    (* Note that this is the tail-recursive Core_list.map *)
    let to_list t = List.map (Doubly_linked.to_list t.queue) ~f:Key_value.value
    let to_array t = Array.map (Doubly_linked.to_array t.queue) ~f:Key_value.value

    let for_all t ~f =
      read t (fun () -> Doubly_linked.for_all t.queue ~f:(fun kv -> f kv.value))
    ;;

    let exists t ~f =
      read t (fun () -> Doubly_linked.exists t.queue ~f:(fun kv -> f kv.value))
    ;;

    let find_map t ~f =
      read t (fun () -> Doubly_linked.find_map t.queue ~f:(fun kv -> f kv.value))
    ;;

    let find t ~f =
      read t (fun () ->
        Option.map
          (Doubly_linked.find t.queue ~f:(fun kv -> f kv.value))
          ~f:Key_value.value)
    ;;

    let enqueue t back_or_front key value =
      ensure_can_modify t;
      if Table.mem t.table key
      then `Key_already_present
      else (
        let contents = { Key_value.key; value } in
        let elt =
          match back_or_front with
          | `back -> Doubly_linked.insert_last t.queue contents
          | `front -> Doubly_linked.insert_first t.queue contents
        in
        Table.set t.table ~key ~data:elt;
        `Ok)
    ;;

    let enqueue_back t = enqueue t `back
    let enqueue_front t = enqueue t `front

    let raise_enqueue_duplicate_key t key =
      raise_s
        [%message
          "Hash_queue.enqueue_exn: duplicate key"
            ~_:(Table.sexp_of_key t.table key : Sexp.t)]
    ;;

    let enqueue_exn t back_or_front key value =
      match enqueue t back_or_front key value with
      | `Key_already_present -> raise_enqueue_duplicate_key t key
      | `Ok -> ()
    ;;

    let enqueue_back_exn t = enqueue_exn t `back
    let enqueue_front_exn t = enqueue_exn t `front

    (* Performance hack: we implement this version separately to avoid allocation from the
       option. *)
    let lookup_and_move_to_back_exn t key =
      ensure_can_modify t;
      let elt = Table.find_exn t.table key in
      Doubly_linked.move_to_back t.queue elt;
      Key_value.value (Elt.value elt)
    ;;

    let lookup_and_move_to_back t key =
      let open Option.Let_syntax in
      ensure_can_modify t;
      let%map elt = Table.find t.table key in
      Doubly_linked.move_to_back t.queue elt;
      Key_value.value (Elt.value elt)
    ;;

    let lookup_and_move_to_front_exn t key =
      ensure_can_modify t;
      let elt = Table.find_exn t.table key in
      Doubly_linked.move_to_front t.queue elt;
      Key_value.value (Elt.value elt)
    ;;

    let lookup_and_move_to_front t key =
      let open Option.Let_syntax in
      ensure_can_modify t;
      let%map elt = Table.find t.table key in
      Doubly_linked.move_to_front t.queue elt;
      Key_value.value (Elt.value elt)
    ;;

    let dequeue_with_key t back_or_front =
      ensure_can_modify t;
      let maybe_kv =
        match back_or_front with
        | `back -> Doubly_linked.remove_last t.queue
        | `front -> Doubly_linked.remove_first t.queue
      in
      match maybe_kv with
      | None -> None
      | Some kv ->
        Table.remove t.table kv.key;
        Some (kv.key, kv.value)
    ;;

    let raise_dequeue_with_key_empty () =
      raise_s [%message "Hash_queue.dequeue_with_key: empty queue"]
    ;;

    let dequeue_with_key_exn t back_or_front =
      match dequeue_with_key t back_or_front with
      | None -> raise_dequeue_with_key_empty ()
      | Some (k, v) -> k, v
    ;;

    let dequeue_back_with_key t = dequeue_with_key t `back
    let dequeue_back_with_key_exn t = dequeue_with_key_exn t `back
    let dequeue_front_with_key t = dequeue_with_key t `front
    let dequeue_front_with_key_exn t = dequeue_with_key_exn t `front

    let dequeue t back_or_front =
      match dequeue_with_key t back_or_front with
      | None -> None
      | Some (_, v) -> Some v
    ;;

    let dequeue_back t = dequeue t `back
    let dequeue_front t = dequeue t `front

    let last_with_key t =
      match Doubly_linked.last t.queue with
      | None -> None
      | Some { key; value } -> Some (key, value)
    ;;

    let last t =
      match Doubly_linked.last t.queue with
      | None -> None
      | Some kv -> Some kv.value
    ;;

    let first_with_key t =
      match Doubly_linked.first t.queue with
      | None -> None
      | Some { key; value } -> Some (key, value)
    ;;

    let first t =
      match Doubly_linked.first t.queue with
      | None -> None
      | Some kv -> Some kv.value
    ;;

    let raise_dequeue_empty () = raise_s [%message "Hash_queue.dequeue_exn: empty queue"]

    let dequeue_exn t back_or_front =
      match dequeue t back_or_front with
      | None -> raise_dequeue_empty ()
      | Some v -> v
    ;;

    let dequeue_back_exn t = dequeue_exn t `back
    let dequeue_front_exn t = dequeue_exn t `front

    let keys t =
      (* Return the keys in the order of the queue. *)
      List.map (Doubly_linked.to_list t.queue) ~f:Key_value.key
    ;;

    let iteri t ~f =
      read t (fun () ->
        Doubly_linked.iter t.queue ~f:(fun kv -> f ~key:kv.key ~data:kv.value))
    ;;

    let iter t ~f = iteri t ~f:(fun ~key:_ ~data -> f data)

    let foldi t ~init ~f =
      read t (fun () ->
        Doubly_linked.fold t.queue ~init ~f:(fun ac kv ->
          f ac ~key:kv.key ~data:kv.value))
    ;;

    let fold t ~init ~f = foldi t ~init ~f:(fun ac ~key:_ ~data -> f ac data)
    let count t ~f = Container.count ~fold t ~f
    let sum m t ~f = Container.sum m ~fold t ~f
    let min_elt t ~compare = Container.min_elt ~fold t ~compare
    let max_elt t ~compare = Container.max_elt ~fold t ~compare
    let fold_result t ~init ~f = Container.fold_result ~fold ~init ~f t
    let fold_until t ~init ~f = Container.fold_until ~fold ~init ~f t

    let dequeue_all t ~f =
      let rec loop () =
        match dequeue_front t with
        | None -> ()
        | Some v ->
          f v;
          loop ()
      in
      loop ()
    ;;

    let remove t k =
      ensure_can_modify t;
      match Table.find_and_remove t.table k with
      | None -> `No_such_key
      | Some elt ->
        Doubly_linked.remove t.queue elt;
        `Ok
    ;;

    let raise_remove_unknown_key t key =
      raise_s
        [%message
          "Hash_queue.remove_exn: unknown key" ~_:(Table.sexp_of_key t.table key : Sexp.t)]
    ;;

    let remove_exn t k =
      ensure_can_modify t;
      match remove t k with
      | `No_such_key -> raise_remove_unknown_key t k
      | `Ok -> ()
    ;;

    let lookup_and_remove t k =
      ensure_can_modify t;
      match Table.find_and_remove t.table k with
      | None -> None
      | Some elt ->
        Doubly_linked.remove t.queue elt;
        Some (Elt.value elt).value
    ;;

    let replace t k v =
      ensure_can_modify t;
      match Table.find t.table k with
      | None -> `No_such_key
      | Some elt ->
        (Elt.value elt).value <- v;
        `Ok
    ;;

    let raise_replace_unknown_key t key =
      raise_s
        [%message
          "Hash_queue.replace_exn: unknown key"
            ~_:(Table.sexp_of_key t.table key : Sexp.t)]
    ;;

    let replace_exn t k v =
      ensure_can_modify t;
      match replace t k v with
      | `No_such_key -> raise_replace_unknown_key t k
      | `Ok -> ()
    ;;

    let drop ?(n = 1) t back_or_front =
      if n >= length t
      then clear t
      else
        for _ = 1 to n do
          ignore (dequeue_with_key t back_or_front : _ option)
        done
    ;;

    let drop_back ?n t = drop ?n t `back
    let drop_front ?n t = drop ?n t `front

    let copy t =
      let copied = create ~size:(length t) (Table.hashable t.table) in
      iteri t ~f:(fun ~key ~data -> enqueue_back_exn copied key data);
      copied
    ;;
  end

  module type S = S0 with type ('key, 'data) hash_queue := ('key, 'data) Backend.t

  module Make_with_hashable (T : sig
      module Key : Key

      val hashable : Key.t Hashtbl.Hashable.t
    end) : S with type key = T.Key.t = struct
    include (Backend : Backend with type ('k, 'd) t := ('k, 'd) Backend.t)

    type key = T.Key.t
    type 'data t = (T.Key.t, 'data) Backend.t [@@deriving sexp_of]

    let hashable = T.hashable
    let create ?growth_allowed ?size () = create ?growth_allowed ?size hashable
  end

  module Make (Key : Key) : S with type key = Key.t = Make_with_hashable (struct
      module Key = Key

      let hashable = Table.Hashable.of_key (module Key)
    end)

  include Backend
end

include Make_backend (Hashtbl)