package octez-libs

  1. Overview
  2. Docs
package octez-libs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file lazy_vector.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
394
395
396
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2022 Trili Tech  <contact@trili.tech>                       *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

exception Bounds

exception SizeOverflow

module type KeyS = sig
  include Map.OrderedType

  val unsigned_compare : t -> t -> int

  val zero : t

  val add : t -> t -> t

  val sub : t -> t -> t

  val pred : t -> t

  val succ : t -> t

  val to_string : t -> string
end

module type S = sig
  type key

  type 'a producer = key -> 'a Lwt.t

  module Map : Lazy_map.S with type key = key

  type 'a t

  val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit

  val to_string : ('a -> string) -> 'a t -> string

  val string_of_key : key -> string

  val num_elements : 'a t -> key

  val create :
    ?first_key:key ->
    ?values:'a Map.Map.t ->
    ?produce_value:'a producer ->
    ?origin:Tezos_tree_encoding.wrapped_tree ->
    key ->
    'a t

  val origin : 'a t -> Tezos_tree_encoding.wrapped_tree option

  val empty : unit -> 'a t

  val singleton : 'a -> 'a t

  val of_list : 'a list -> 'a t

  val get : key -> 'a t -> 'a Lwt.t

  val set : key -> 'a -> 'a t -> 'a t

  val cons : 'a -> 'a t -> 'a t

  val split : 'a t -> key -> 'a t * 'a t

  val grow : ?default:(unit -> 'a) -> key -> 'a t -> 'a t

  val drop : 'a t -> 'a t

  val pop : 'a t -> ('a * 'a t) Lwt.t

  val prepend_list : 'a list -> 'a t -> 'a t

  val append : 'a -> 'a t -> 'a t * key

  val concat : 'a t -> 'a t -> 'a t Lwt.t

  val unsafe_concat : 'a t -> 'a t -> 'a t

  val to_list : 'a t -> 'a list Lwt.t

  val loaded_bindings : 'a t -> (key * 'a option) list

  val first_key : 'a t -> key

  val encoding :
    key Tezos_tree_encoding.t ->
    'a Tezos_tree_encoding.t ->
    'a t Tezos_tree_encoding.t
end

module ZZ : KeyS with type t = Z.t = struct
  include Z

  (** Note that, in fixed sized integers we need to use a specialized `unsigned`
       version of compare. This is because, internally, some keys can be
       represented by negative integers (using wraparound). For example after a
       while the value of num_elements will surpass max_int and so it will
       become negative Nevertheless we still want this to represent large
       unsigned integers (up until 2*max_int). In the case of Z this is not an
       issue as there is no wraparound.*)
  let unsigned_compare = Z.compare
end

module Make_no_enc (Key : KeyS) = struct
  module Map = Lazy_map.Make (Key)

  type key = Key.t

  type 'a producer = key -> 'a Lwt.t

  type 'a t = {first : key; num_elements : key; values : 'a Map.t}

  let pp pp_value fmt map =
    Format.fprintf
      fmt
      "@[<hv 2>{ first = %s;@ num_elements = %s;@ values = %a }@]"
      (Key.to_string map.first)
      (Key.to_string map.num_elements)
      (Map.pp pp_value)
      map.values

  let to_string show_value map =
    let pp_value fmt value = Format.pp_print_string fmt (show_value value) in
    Format.asprintf "%a" (pp pp_value) map

  let string_of_key = Key.to_string

  let num_elements map = map.num_elements

  let create ?(first_key = Key.zero) ?values ?produce_value ?origin num_elements
      =
    let values = Map.create ?values ?produce_value ?origin () in
    {first = first_key; num_elements; values}

  let origin {values; _} = Map.origin values

  let empty () = create Key.zero

  let of_list values =
    let fold (map, len) value = (Map.Map.add len value map, Key.succ len) in
    let values, num_elements =
      List.fold_left fold (Map.Map.empty, Key.zero) values
    in
    create ~values num_elements

  let invalid_key key map = Key.unsigned_compare key map.num_elements >= 0

  let get key map =
    if invalid_key key map then raise Bounds ;
    let key = Key.add map.first key in
    Map.get key map.values

  let set key value map =
    if invalid_key key map then raise Bounds ;
    let key = Key.add map.first key in
    {map with values = Map.set key value map.values}

  let singleton value = create Key.(succ zero) |> set Key.zero value

  let overflow k1 k2 = Key.unsigned_compare k1 (Key.add k1 k2) > 0

  let cons value map =
    if overflow map.num_elements (Key.succ Key.zero) then raise SizeOverflow
    else
      let first = Key.pred map.first in
      let values = Map.set first value map.values in
      let num_elements = Key.succ map.num_elements in
      {first; values; num_elements}

  let split vec at =
    if
      Key.(
        unsigned_compare at zero < 0
        || unsigned_compare (num_elements vec) at < 0)
    then raise Bounds
    else
      ( {first = vec.first; num_elements = at; values = Map.dup vec.values},
        {
          first = Key.(add vec.first at);
          num_elements = Key.(sub vec.num_elements at);
          values = Map.dup vec.values;
        } )

  let append_opt elt map =
    if overflow map.num_elements (Key.succ Key.zero) then raise SizeOverflow
    else
      let num_elements = map.num_elements in
      let map = {map with num_elements = Key.succ num_elements} in
      let map =
        match elt with Some elt -> set num_elements elt map | None -> map
      in
      (map, num_elements)

  (* This version of drop simply doesn't check for bounds, but is used in
     functions actually checking the bounds, to prevent doing it twice. *)
  let unsafe_drop map =
    let values = Map.remove map.first map.values in
    {
      first = Key.succ map.first;
      num_elements = Key.pred map.num_elements;
      values;
    }

  let drop map =
    if Key.(unsigned_compare zero map.num_elements < 0) then unsafe_drop map
    else raise Bounds

  let pop map =
    let open Lwt.Syntax in
    if Key.(unsigned_compare zero map.num_elements < 0) then
      let+ x = get Key.zero map in
      (x, unsafe_drop map)
    else raise Bounds

  let append elt map = append_opt (Some elt) map

  let prepend_list es es0 =
    let es = List.rev es in
    let rec aux v = function x :: rst -> aux (cons x v) rst | [] -> v in
    aux es0 es

  let rec grow ?default delta map =
    if overflow map.num_elements delta then raise SizeOverflow
    else if Key.(delta <= zero) then map
    else
      let map, _ = append_opt (Option.map (fun f -> f ()) default) map in
      grow ?default Key.(pred delta) map

  let to_list map =
    let open Lwt.Syntax in
    let rec unroll acc index =
      if Key.unsigned_compare index Key.zero > 0 then
        let* prefix = get index map in
        (unroll [@ocaml.tailcall]) (prefix :: acc) (Key.pred index)
      else
        let* prefix = get Key.zero map in
        Lwt.return (prefix :: acc)
    in
    (* The empty vector is not correctly taken into account otherwise, since
       `pred zero` = `-1`, which is an invalid key according to
       {!invalid_key}. *)
    if map.num_elements = Key.zero then Lwt.return_nil
    else (unroll [@ocaml.tailcall]) [] (Key.pred map.num_elements)

  let concat lhs rhs =
    let open Lwt.Syntax in
    if overflow lhs.num_elements rhs.num_elements then raise SizeOverflow
    else
      let* lhs = to_list lhs in
      let+ rhs = to_list rhs in
      of_list (lhs @ rhs)

  let loaded_bindings m = Map.loaded_bindings m.values

  let unsafe_concat lhs rhs =
    let lhs = loaded_bindings lhs |> List.map snd in
    let rhs = loaded_bindings rhs |> List.map snd in
    of_list (List.filter_map Fun.id (lhs @ rhs))

  let first_key vector = vector.first
end

module Make (Key : KeyS) : S with type key = Key.t = struct
  module No_enc = Make_no_enc (Key)
  module Encoding = Tezos_tree_encoding.Lazy_vector_encoding.Make (No_enc)
  include No_enc

  let encoding = Encoding.lazy_vector
end

module Int = struct
  include Int

  let unsigned_compare n m = compare (n - min_int) (m - min_int)
end

module IntVector = Make (Int)
module Int32Vector = Make (Int32)
module Int64Vector = Make (Int64)
module ZVector = Make (ZZ)

module Mutable = struct
  module type ImmutableS = S

  module type S = sig
    type key

    module Vector : S with type key = key

    type 'a t

    val num_elements : 'a t -> key

    val of_immutable : 'a Vector.t -> 'a t

    val create :
      ?values:'a Vector.Map.Map.t ->
      ?produce_value:'a Vector.producer ->
      ?origin:Tezos_tree_encoding.wrapped_tree ->
      key ->
      'a t

    val origin : 'a t -> Tezos_tree_encoding.wrapped_tree option

    val get : key -> 'a t -> 'a Lwt.t

    val set : key -> 'a -> 'a t -> unit

    val grow : ?default:(unit -> 'a) -> key -> 'a t -> unit

    val append : 'a -> 'a t -> key

    val cons : 'a -> 'a t -> unit

    val drop : 'a t -> unit

    val pop : 'a t -> 'a Lwt.t

    val reset : 'a t -> unit

    val snapshot : 'a t -> 'a Vector.t
  end

  module Make (Vector : ImmutableS) :
    S with type key = Vector.key and module Vector = Vector = struct
    module Vector = Vector

    type key = Vector.key

    type 'a t = 'a Vector.t ref

    let num_elements map_ref = Vector.num_elements !map_ref

    let of_immutable = ref

    let create ?values ?produce_value ?origin num_elements =
      of_immutable (Vector.create ?values ?produce_value ?origin num_elements)

    let origin vector = Vector.origin !vector

    let get key map_ref = Vector.get key !map_ref

    let set key value map_ref = map_ref := Vector.set key value !map_ref

    let grow ?default delta map_ref =
      map_ref := Vector.grow ?default delta !map_ref

    let append elt map_ref =
      let new_map, i = Vector.append elt !map_ref in
      map_ref := new_map ;
      i

    let cons a map_ref = map_ref := Vector.cons a !map_ref

    let drop map_ref = map_ref := Vector.drop !map_ref

    let pop map_ref =
      let open Lwt.Syntax in
      let+ v, map = Vector.pop !map_ref in
      map_ref := map ;
      v

    let reset map_ref = map_ref := Vector.empty ()

    let snapshot map_ref = !map_ref
  end

  module IntVector = Make (IntVector)
  module Int32Vector = Make (Int32Vector)
  module Int64Vector = Make (Int64Vector)
  module ZVector = Make (ZVector)
end
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