My working unpac space for OCaml projects in development
Merge opam/patches/lwt-dllist
+1155
+14
vendor/opam/lwt-dllist/CHANGES.md
+14
vendor/opam/lwt-dllist/CHANGES.md
···
1
+
## v1.1.0 (2025-04-28)
2
+
3
+
- Add missing primitive `clear` (@raphael-proust, #7)
4
+
- Fix documentation typo (@raphael-proust, #7)
5
+
6
+
## v1.0.1 (2021-05-21)
7
+
8
+
- Remove `lwt` dependency; it's only really needed for the tests (@aantron #1).
9
+
- Fix deprecation warnings with OCaml 4.08 (@aantron #1).
10
+
- Add support for OCaml 4.02 (@aantron #1).
11
+
12
+
## v1.0.0 (2019-01-14)
13
+
14
+
Initial release, based on Lwt 4.1.0's source code.
+17
vendor/opam/lwt-dllist/LICENSE.md
+17
vendor/opam/lwt-dllist/LICENSE.md
···
1
+
Permission is hereby granted, free of charge, to any person obtaining a copy
2
+
of this software and associated documentation files (the "Software"), to deal
3
+
in the Software without restriction, including without limitation the rights
4
+
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
5
+
copies of the Software, and to permit persons to whom the Software is
6
+
furnished to do so, subject to the following conditions:
7
+
8
+
The above copyright notice and this permission notice shall be included in all
9
+
copies or substantial portions of the Software.
10
+
11
+
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
12
+
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
13
+
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
14
+
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
15
+
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
16
+
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
17
+
SOFTWARE.
+13
vendor/opam/lwt-dllist/Makefile
+13
vendor/opam/lwt-dllist/Makefile
+25
vendor/opam/lwt-dllist/README.md
+25
vendor/opam/lwt-dllist/README.md
···
1
+
# lwt-dllist - Mutable doubly-linked list
2
+
3
+
An `Lwt_dllist` is an object holding a list of elements which support
4
+
the following operations:
5
+
6
+
- adding an element to the left or the right in time and space O(1)
7
+
- taking an element from the left or the right in time and space O(1)
8
+
- removing a previously added element from a sequence in time and space O(1)
9
+
- removing an element while the sequence is being traversed.
10
+
11
+
## History
12
+
13
+
This module was formerly part of the Lwt core distribution as the
14
+
`Lwt_sequence` module, but has been pulled out into a separate library since it
15
+
is really just an implementation detail of Lwt.
16
+
17
+
You can migrate existing uses of `Lwt_sequence` into `Lwt_dllist` by simply
18
+
renaming the module. The implementation of the module remains unchanged, but
19
+
the name reflects the fact that the implementation is a doubly-linked list.
20
+
21
+
## Further Reading
22
+
23
+
- Docs: <https://mirage.github.io/lwt-dllist>
24
+
- Issues: <https://github.com/mirage/lwt-dllist/issues>
25
+
- Discussion: <https://discuss.ocaml.org> with the MirageOS tag.
+28
vendor/opam/lwt-dllist/lwt-dllist.opam
+28
vendor/opam/lwt-dllist/lwt-dllist.opam
···
1
+
opam-version: "2.0"
2
+
maintainer: [ "Anil Madhavapeddy <anil@recoil.org>" ]
3
+
authors: ["Jérôme Vouillon" "Jérémie Dimino"]
4
+
license: "MIT"
5
+
homepage: "https://github.com/mirage/lwt-dllist"
6
+
doc: "https://mirage.github.io/lwt-dllist/"
7
+
bug-reports: "https://github.com/mirage/lwt-dllist/issues"
8
+
depends: [
9
+
"ocaml" {>= "4.02.0"}
10
+
"lwt" {with-test}
11
+
"dune"
12
+
]
13
+
build: [
14
+
["dune" "subst" ] {dev}
15
+
["dune" "build" "-p" name "-j" jobs]
16
+
["dune" "runtest" "-p" name "-j" jobs] {with-test}
17
+
]
18
+
dev-repo: "git+https://github.com/mirage/lwt-dllist.git"
19
+
synopsis: "Mutable doubly-linked list with Lwt iterators"
20
+
description: """
21
+
A sequence is an object holding a list of elements which support
22
+
the following operations:
23
+
24
+
- adding an element to the left or the right in time and space O(1)
25
+
- taking an element from the left or the right in time and space O(1)
26
+
- removing a previously added element from a sequence in time and space O(1)
27
+
- removing an element while the sequence is being transversed.
28
+
"""
+4
vendor/opam/lwt-dllist/src/dune
+4
vendor/opam/lwt-dllist/src/dune
+230
vendor/opam/lwt-dllist/src/lwt_dllist.ml
+230
vendor/opam/lwt-dllist/src/lwt_dllist.ml
···
1
+
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
2
+
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
3
+
4
+
5
+
6
+
exception Empty
7
+
8
+
type 'a t = {
9
+
mutable prev : 'a t;
10
+
mutable next : 'a t;
11
+
}
12
+
13
+
type 'a node = {
14
+
node_prev : 'a t;
15
+
node_next : 'a t;
16
+
mutable node_data : 'a;
17
+
mutable node_active : bool;
18
+
}
19
+
20
+
external seq_of_node : 'a node -> 'a t = "%identity"
21
+
external node_of_seq : 'a t -> 'a node = "%identity"
22
+
23
+
(* +-----------------------------------------------------------------+
24
+
| Operations on nodes |
25
+
+-----------------------------------------------------------------+ *)
26
+
27
+
let get node =
28
+
node.node_data
29
+
30
+
let set node data =
31
+
node.node_data <- data
32
+
33
+
let remove node =
34
+
if node.node_active then begin
35
+
node.node_active <- false;
36
+
let seq = seq_of_node node in
37
+
seq.prev.next <- seq.next;
38
+
seq.next.prev <- seq.prev
39
+
end
40
+
41
+
(* +-----------------------------------------------------------------+
42
+
| Operations on sequences |
43
+
+-----------------------------------------------------------------+ *)
44
+
45
+
let create () =
46
+
let rec seq = { prev = seq; next = seq } in
47
+
seq
48
+
49
+
let clear seq =
50
+
seq.prev <- seq;
51
+
seq.next <- seq
52
+
53
+
let is_empty seq = seq.next == seq
54
+
55
+
let length seq =
56
+
let rec loop curr len =
57
+
if curr == seq then
58
+
len
59
+
else
60
+
let node = node_of_seq curr in loop node.node_next (len + 1)
61
+
in
62
+
loop seq.next 0
63
+
64
+
let add_l data seq =
65
+
let node = { node_prev = seq; node_next = seq.next; node_data = data; node_active = true } in
66
+
seq.next.prev <- seq_of_node node;
67
+
seq.next <- seq_of_node node;
68
+
node
69
+
70
+
let add_r data seq =
71
+
let node = { node_prev = seq.prev; node_next = seq; node_data = data; node_active = true } in
72
+
seq.prev.next <- seq_of_node node;
73
+
seq.prev <- seq_of_node node;
74
+
node
75
+
76
+
let take_l seq =
77
+
if is_empty seq then
78
+
raise Empty
79
+
else begin
80
+
let node = node_of_seq seq.next in
81
+
remove node;
82
+
node.node_data
83
+
end
84
+
85
+
let take_r seq =
86
+
if is_empty seq then
87
+
raise Empty
88
+
else begin
89
+
let node = node_of_seq seq.prev in
90
+
remove node;
91
+
node.node_data
92
+
end
93
+
94
+
let take_opt_l seq =
95
+
if is_empty seq then
96
+
None
97
+
else begin
98
+
let node = node_of_seq seq.next in
99
+
remove node;
100
+
Some node.node_data
101
+
end
102
+
103
+
let take_opt_r seq =
104
+
if is_empty seq then
105
+
None
106
+
else begin
107
+
let node = node_of_seq seq.prev in
108
+
remove node;
109
+
Some node.node_data
110
+
end
111
+
112
+
let transfer_l s1 s2 =
113
+
s2.next.prev <- s1.prev;
114
+
s1.prev.next <- s2.next;
115
+
s2.next <- s1.next;
116
+
s1.next.prev <- s2;
117
+
s1.prev <- s1;
118
+
s1.next <- s1
119
+
120
+
let transfer_r s1 s2 =
121
+
s2.prev.next <- s1.next;
122
+
s1.next.prev <- s2.prev;
123
+
s2.prev <- s1.prev;
124
+
s1.prev.next <- s2;
125
+
s1.prev <- s1;
126
+
s1.next <- s1
127
+
128
+
let iter_l f seq =
129
+
let rec loop curr =
130
+
if curr != seq then begin
131
+
let node = node_of_seq curr in
132
+
if node.node_active then f node.node_data;
133
+
loop node.node_next
134
+
end
135
+
in
136
+
loop seq.next
137
+
138
+
let iter_r f seq =
139
+
let rec loop curr =
140
+
if curr != seq then begin
141
+
let node = node_of_seq curr in
142
+
if node.node_active then f node.node_data;
143
+
loop node.node_prev
144
+
end
145
+
in
146
+
loop seq.prev
147
+
148
+
let iter_node_l f seq =
149
+
let rec loop curr =
150
+
if curr != seq then begin
151
+
let node = node_of_seq curr in
152
+
if node.node_active then f node;
153
+
loop node.node_next
154
+
end
155
+
in
156
+
loop seq.next
157
+
158
+
let iter_node_r f seq =
159
+
let rec loop curr =
160
+
if curr != seq then begin
161
+
let node = node_of_seq curr in
162
+
if node.node_active then f node;
163
+
loop node.node_prev
164
+
end
165
+
in
166
+
loop seq.prev
167
+
168
+
let fold_l f seq acc =
169
+
let rec loop curr acc =
170
+
if curr == seq then
171
+
acc
172
+
else
173
+
let node = node_of_seq curr in
174
+
if node.node_active then
175
+
loop node.node_next (f node.node_data acc)
176
+
else
177
+
loop node.node_next acc
178
+
in
179
+
loop seq.next acc
180
+
181
+
let fold_r f seq acc =
182
+
let rec loop curr acc =
183
+
if curr == seq then
184
+
acc
185
+
else
186
+
let node = node_of_seq curr in
187
+
if node.node_active then
188
+
loop node.node_prev (f node.node_data acc)
189
+
else
190
+
loop node.node_prev acc
191
+
in
192
+
loop seq.prev acc
193
+
194
+
let find_node_l f seq =
195
+
let rec loop curr =
196
+
if curr != seq then
197
+
let node = node_of_seq curr in
198
+
if node.node_active then
199
+
if f node.node_data then
200
+
node
201
+
else
202
+
loop node.node_next
203
+
else
204
+
loop node.node_next
205
+
else
206
+
raise Not_found
207
+
in
208
+
loop seq.next
209
+
210
+
let find_node_r f seq =
211
+
let rec loop curr =
212
+
if curr != seq then
213
+
let node = node_of_seq curr in
214
+
if node.node_active then
215
+
if f node.node_data then
216
+
node
217
+
else
218
+
loop node.node_prev
219
+
else
220
+
loop node.node_prev
221
+
else
222
+
raise Not_found
223
+
in
224
+
loop seq.prev
225
+
226
+
let find_node_opt_l f seq =
227
+
try Some (find_node_l f seq) with Not_found -> None
228
+
229
+
let find_node_opt_r f seq =
230
+
try Some (find_node_r f seq) with Not_found -> None
+141
vendor/opam/lwt-dllist/src/lwt_dllist.mli
+141
vendor/opam/lwt-dllist/src/lwt_dllist.mli
···
1
+
(* This file is formerly part of Lwt, released under the MIT license.
2
+
* See LICENSE.md for details, or visit
3
+
* https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
4
+
5
+
(** Mutable double-linked list of elements *)
6
+
7
+
(** A sequence is an object holding a list of elements which support
8
+
the following operations:
9
+
10
+
- adding an element to the left or the right in time and space O(1)
11
+
- taking an element from the left or the right in time and space O(1)
12
+
- removing a previously added element from a sequence in time and space O(1)
13
+
- removing an element while the sequence is being transversed.
14
+
*)
15
+
16
+
type 'a t
17
+
(** Type of a sequence holding values of type ['a] *)
18
+
19
+
type 'a node
20
+
(** Type of a node holding one value of type ['a] in a sequence *)
21
+
22
+
(** {2 Operation on nodes} *)
23
+
24
+
val get : 'a node -> 'a
25
+
(** Returns the contents of a node *)
26
+
27
+
val set : 'a node -> 'a -> unit
28
+
(** Changes the contents of a node *)
29
+
30
+
val remove : 'a node -> unit
31
+
(** Removes a node from the sequence it is part of. It does nothing
32
+
if the node has already been removed. *)
33
+
34
+
(** {2 Operations on sequence} *)
35
+
36
+
val create : unit -> 'a t
37
+
(** [create ()] creates a new empty sequence *)
38
+
39
+
val clear : 'a t -> unit
40
+
(** Removes all nodes from the given sequence. The nodes are not actually
41
+
mutated to note their removal. Only the sequence's pointers are updated. *)
42
+
43
+
val is_empty : 'a t -> bool
44
+
(** Returns [true] iff the given sequence is empty *)
45
+
46
+
val length : 'a t -> int
47
+
(** Returns the number of elements in the given sequence. This is a
48
+
O(n) operation where [n] is the number of elements in the
49
+
sequence. *)
50
+
51
+
val add_l : 'a -> 'a t -> 'a node
52
+
(** [add_l x s] adds [x] to the left of the sequence [s] *)
53
+
54
+
val add_r : 'a -> 'a t -> 'a node
55
+
(** [add_r x s] adds [x] to the right of the sequence [s] *)
56
+
57
+
exception Empty
58
+
(** Exception raised by [take_l] and [take_r] and when the sequence
59
+
is empty *)
60
+
61
+
val take_l : 'a t -> 'a
62
+
(** [take_l x s] removes and returns the leftmost element of [s]
63
+
64
+
@raise Empty if the sequence is empty *)
65
+
66
+
val take_r : 'a t -> 'a
67
+
(** [take_r x s] removes and returns the rightmost element of [s]
68
+
69
+
@raise Empty if the sequence is empty *)
70
+
71
+
val take_opt_l : 'a t -> 'a option
72
+
(** [take_opt_l x s] removes and returns [Some x] where [x] is the
73
+
leftmost element of [s] or [None] if [s] is empty *)
74
+
75
+
val take_opt_r : 'a t -> 'a option
76
+
(** [take_opt_r x s] removes and returns [Some x] where [x] is the
77
+
rightmost element of [s] or [None] if [s] is empty *)
78
+
79
+
val transfer_l : 'a t -> 'a t -> unit
80
+
(** [transfer_l s1 s2] removes all elements of [s1] and add them at
81
+
the left of [s2]. This operation runs in constant time and
82
+
space. *)
83
+
84
+
val transfer_r : 'a t -> 'a t -> unit
85
+
(** [transfer_r s1 s2] removes all elements of [s1] and add them at
86
+
the right of [s2]. This operation runs in constant time and
87
+
space. *)
88
+
89
+
(** {2 Sequence iterators} *)
90
+
91
+
(** Note: it is OK to remove a node while traversing a sequence *)
92
+
93
+
val iter_l : ('a -> unit) -> 'a t -> unit
94
+
(** [iter_l f s] applies [f] on all elements of [s] starting from
95
+
the left *)
96
+
97
+
val iter_r : ('a -> unit) -> 'a t -> unit
98
+
(** [iter_r f s] applies [f] on all elements of [s] starting from
99
+
the right *)
100
+
101
+
val iter_node_l : ('a node -> unit) -> 'a t -> unit
102
+
(** [iter_node_l f s] applies [f] on all nodes of [s] starting from
103
+
the left *)
104
+
105
+
val iter_node_r : ('a node -> unit) -> 'a t -> unit
106
+
(** [iter_node_r f s] applies [f] on all nodes of [s] starting from
107
+
the right *)
108
+
109
+
val fold_l : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
110
+
(** [fold_l f s] is:
111
+
{[
112
+
fold_l f s x = f en (... (f e2 (f e1 x)))
113
+
]}
114
+
where [e1], [e2], ..., [en] are the elements of [s]
115
+
*)
116
+
117
+
val fold_r : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
118
+
(** [fold_r f s] is:
119
+
{[
120
+
fold_r f s x = f e1 (f e2 (... (f en x)))
121
+
]}
122
+
where [e1], [e2], ..., [en] are the elements of [s]
123
+
*)
124
+
125
+
val find_node_opt_l : ('a -> bool) -> 'a t -> 'a node option
126
+
(** [find_node_opt_l f s] returns [Some x], where [x] is the first node of
127
+
[s] starting from the left that satisfies [f] or [None] if none
128
+
exists. *)
129
+
130
+
val find_node_opt_r : ('a -> bool) -> 'a t -> 'a node option
131
+
(** [find_node_opt_r f s] returns [Some x], where [x] is the first node of
132
+
[s] starting from the right that satisfies [f] or [None] if none
133
+
exists. *)
134
+
135
+
val find_node_l : ('a -> bool) -> 'a t -> 'a node
136
+
(** [find_node_l f s] returns the first node of [s] starting from the left
137
+
that satisfies [f] or raises [Not_found] if none exists. *)
138
+
139
+
val find_node_r : ('a -> bool) -> 'a t -> 'a node
140
+
(** [find_node_r f s] returns the first node of [s] starting from the right
141
+
that satisfies [f] or raises [Not_found] if none exists. *)
+8
vendor/opam/lwt-dllist/test/dune
+8
vendor/opam/lwt-dllist/test/dune
+1
vendor/opam/lwt-dllist/test/main.ml
+1
vendor/opam/lwt-dllist/test/main.ml
···
1
+
Test.run "dllist" [ Test_lwt_dllist.suite ]
+211
vendor/opam/lwt-dllist/test/test.ml
+211
vendor/opam/lwt-dllist/test/test.ml
···
1
+
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
2
+
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
3
+
4
+
[@@@warning "-4"]
5
+
6
+
type test = {
7
+
test_name : string;
8
+
skip_if_this_is_false : unit -> bool;
9
+
run : unit -> bool Lwt.t;
10
+
}
11
+
12
+
type outcome =
13
+
| Passed
14
+
| Failed
15
+
| Exception of exn
16
+
| Skipped
17
+
18
+
exception Skip
19
+
20
+
let test_direct test_name ?(only_if = fun () -> true) run =
21
+
let run =
22
+
fun () ->
23
+
Lwt.return (run ())
24
+
in
25
+
{test_name; skip_if_this_is_false = only_if; run}
26
+
27
+
let test test_name ?(only_if = fun () -> true) run =
28
+
{test_name; skip_if_this_is_false = only_if; run}
29
+
30
+
let run_test : test -> outcome Lwt.t = fun test ->
31
+
if test.skip_if_this_is_false () = false then
32
+
Lwt.return Skipped
33
+
34
+
else begin
35
+
(* Lwt.async_exception_hook handling inspired by
36
+
https://github.com/mirage/alcotest/issues/45 *)
37
+
let async_exception_promise, async_exception_occurred = Lwt.task () in
38
+
let old_async_exception_hook = !Lwt.async_exception_hook in
39
+
Lwt.async_exception_hook := (fun exn ->
40
+
Lwt.wakeup_later async_exception_occurred (Exception exn));
41
+
42
+
Lwt.finalize
43
+
(fun () ->
44
+
45
+
let test_completion_promise =
46
+
Lwt.try_bind
47
+
(fun () ->
48
+
test.run ())
49
+
50
+
(fun test_did_pass ->
51
+
if test_did_pass then
52
+
Lwt.return Passed
53
+
else
54
+
Lwt.return Failed)
55
+
56
+
(function
57
+
| Skip ->
58
+
Lwt.return Skipped
59
+
60
+
| exn_raised_by_test ->
61
+
Lwt.return (Exception exn_raised_by_test))
62
+
in
63
+
64
+
Lwt.pick [test_completion_promise; async_exception_promise])
65
+
66
+
(fun () ->
67
+
Lwt.async_exception_hook := old_async_exception_hook;
68
+
Lwt.return_unit)
69
+
end
70
+
71
+
let outcome_to_character : outcome -> string = function
72
+
| Passed -> "."
73
+
| Failed -> "F"
74
+
| Exception _ -> "E"
75
+
| Skipped -> "S"
76
+
77
+
78
+
79
+
type suite = {
80
+
suite_name : string;
81
+
suite_tests : test list;
82
+
skip_suite_if_this_is_false : unit -> bool;
83
+
}
84
+
85
+
let suite name ?(only_if = fun () -> true) tests =
86
+
{suite_name = name;
87
+
suite_tests = tests;
88
+
skip_suite_if_this_is_false = only_if}
89
+
90
+
let run_test_suite : suite -> ((string * outcome) list) Lwt.t = fun suite ->
91
+
if suite.skip_suite_if_this_is_false () = false then
92
+
let outcomes =
93
+
suite.suite_tests
94
+
|> List.map (fun {test_name; _} -> (test_name, Skipped))
95
+
in
96
+
(outcome_to_character Skipped).[0]
97
+
|> String.make (List.length outcomes)
98
+
|> print_string;
99
+
flush stdout;
100
+
101
+
Lwt.return outcomes
102
+
103
+
else
104
+
suite.suite_tests |> Lwt_list.map_s begin fun test ->
105
+
Lwt.bind (run_test test) (fun outcome ->
106
+
outcome |> outcome_to_character |> print_string;
107
+
flush stdout;
108
+
Lwt.return (test.test_name, outcome))
109
+
end
110
+
111
+
let outcomes_all_ok : (string * outcome) list -> bool =
112
+
List.for_all (fun (_test_name, outcome) ->
113
+
match outcome with
114
+
| Passed | Skipped -> true
115
+
| Failed | Exception _ -> false)
116
+
117
+
let show_failures : (string * outcome) list -> unit =
118
+
List.iter (fun (test_name, outcome) ->
119
+
match outcome with
120
+
| Passed
121
+
| Skipped ->
122
+
()
123
+
124
+
| Failed ->
125
+
Printf.eprintf
126
+
"Test '%s' produced 'false'\n" test_name
127
+
128
+
| Exception exn ->
129
+
Printf.eprintf
130
+
"Test '%s' raised '%s'\n" test_name (Printexc.to_string exn))
131
+
132
+
133
+
134
+
type aggregated_outcomes = (string * ((string * outcome) list)) list
135
+
136
+
let fold_over_outcomes :
137
+
('a -> suite_name:string -> test_name:string -> outcome -> 'a) ->
138
+
'a ->
139
+
aggregated_outcomes ->
140
+
'a =
141
+
142
+
fun f init outcomes ->
143
+
144
+
List.fold_left (fun accumulator (suite_name, test_outcomes) ->
145
+
List.fold_left (fun accumulator (test_name, test_outcome) ->
146
+
f accumulator ~suite_name ~test_name test_outcome)
147
+
accumulator
148
+
test_outcomes)
149
+
init
150
+
outcomes
151
+
152
+
let count_ran : aggregated_outcomes -> int =
153
+
fold_over_outcomes
154
+
(fun count ~suite_name:_ ~test_name:_ -> function
155
+
| Skipped ->
156
+
count
157
+
| _ ->
158
+
count + 1)
159
+
0
160
+
161
+
let count_skipped : aggregated_outcomes -> int =
162
+
fold_over_outcomes
163
+
(fun count ~suite_name:_ ~test_name:_ -> function
164
+
| Skipped ->
165
+
count + 1
166
+
| _ ->
167
+
count)
168
+
0
169
+
170
+
(* Runs a series of test suites. If one of the test suites fails, does not run
171
+
subsequent suites. *)
172
+
let run library_name suites =
173
+
Printexc.register_printer (function
174
+
| Failure message -> Some (Printf.sprintf "Failure(%S)" message)
175
+
| _ -> None);
176
+
177
+
Printf.printf "Testing library '%s'...\n" library_name;
178
+
179
+
let rec loop_over_suites aggregated_outcomes suites =
180
+
match suites with
181
+
| [] ->
182
+
Printf.printf
183
+
"\nOk. %i tests ran, %i tests skipped\n"
184
+
(count_ran aggregated_outcomes)
185
+
(count_skipped aggregated_outcomes);
186
+
Lwt.return_unit
187
+
188
+
| suite::rest ->
189
+
Lwt.bind (run_test_suite suite) begin fun outcomes ->
190
+
if not (outcomes_all_ok outcomes) then begin
191
+
print_newline ();
192
+
flush stdout;
193
+
Printf.eprintf "Failures in test suite '%s':\n" suite.suite_name;
194
+
show_failures outcomes;
195
+
exit 1
196
+
end
197
+
else
198
+
loop_over_suites
199
+
((suite.suite_name, outcomes)::aggregated_outcomes) rest
200
+
end
201
+
in
202
+
203
+
loop_over_suites [] suites
204
+
|> Lwt_main.run
205
+
206
+
let with_async_exception_hook hook f =
207
+
let old_hook = !Lwt.async_exception_hook in
208
+
Lwt.async_exception_hook := hook;
209
+
Lwt.finalize f (fun () ->
210
+
Lwt.async_exception_hook := old_hook;
211
+
Lwt.return ())
+40
vendor/opam/lwt-dllist/test/test.mli
+40
vendor/opam/lwt-dllist/test/test.mli
···
1
+
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
2
+
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
3
+
4
+
5
+
6
+
(** Helpers for tests. *)
7
+
8
+
type test
9
+
(** Type of a test *)
10
+
11
+
type suite
12
+
(** Type of a suite of tests *)
13
+
14
+
exception Skip
15
+
(** In some tests, it is only clear that the test should be skipped after it has
16
+
started running (for example, after an attempted system call raises a
17
+
certain exception, indicating it is not supported).
18
+
19
+
Such tests should raise [Test.Skip], or reject their final promise with
20
+
[Test.Skip]. *)
21
+
22
+
val test_direct : string -> ?only_if:(unit -> bool) -> (unit -> bool) -> test
23
+
(** Defines a test. [run] must returns [true] if the test succeeded
24
+
and [false] otherwise. [only_if] is used to conditionally skip the
25
+
test. *)
26
+
27
+
val test : string -> ?only_if:(unit -> bool) -> (unit -> bool Lwt.t) -> test
28
+
(** Like [test_direct], but defines a test which runs a thread. *)
29
+
30
+
val suite : string -> ?only_if:(unit -> bool) -> test list -> suite
31
+
(** Defines a suite of tests *)
32
+
33
+
val run : string -> suite list -> unit
34
+
(** Run all the given tests and exit the program with an exit code
35
+
of [0] if all tests succeeded and with [1] otherwise. *)
36
+
37
+
val with_async_exception_hook : (exn -> unit) -> (unit -> 'a Lwt.t) -> 'a Lwt.t
38
+
(** [Test.with_async_exception_hook hook f] sets [!Lwt.async_exception_hook] to
39
+
[hook], runs [f ()], and then restores [!Lwt.async_exception_hook] to its
40
+
former value. *)
+417
vendor/opam/lwt-dllist/test/test_lwt_dllist.ml
+417
vendor/opam/lwt-dllist/test/test_lwt_dllist.ml
···
1
+
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
2
+
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
3
+
4
+
open Test
5
+
6
+
let filled_sequence () =
7
+
let s = Lwt_dllist.create () in
8
+
let _ = Lwt_dllist.add_r 1 s in
9
+
let _ = Lwt_dllist.add_r 2 s in
10
+
let _ = Lwt_dllist.add_r 3 s in
11
+
let _ = Lwt_dllist.add_r 4 s in
12
+
let _ = Lwt_dllist.add_r 5 s in
13
+
let _ = Lwt_dllist.add_r 6 s in
14
+
s
15
+
16
+
let filled_length = 6
17
+
18
+
let leftmost_value = 1
19
+
20
+
let rightmost_value = 6
21
+
22
+
let transfer_sequence () =
23
+
let s = Lwt_dllist.create () in
24
+
let _ = Lwt_dllist.add_r 7 s in
25
+
let _ = Lwt_dllist.add_r 8 s in
26
+
s
27
+
28
+
let transfer_length = 2
29
+
30
+
let empty_array = [||]
31
+
32
+
let l_filled_array = [|1; 2; 3; 4; 5; 6|]
33
+
34
+
let r_filled_array = [|6; 5; 4; 3; 2; 1|]
35
+
36
+
let factorial_sequence = 720
37
+
38
+
let test_iter iter_f array_values seq =
39
+
let index = ref 0 in
40
+
Lwt.catch
41
+
(fun () ->
42
+
iter_f (fun v ->
43
+
assert (v = array_values.(!index));
44
+
index := (!index + 1)) seq;
45
+
Lwt.return_true)
46
+
(function _ -> Lwt.return_false)
47
+
48
+
let test_iter_node iter_f array_values seq =
49
+
let index = ref 0 in
50
+
Lwt.catch
51
+
(fun () ->
52
+
iter_f (fun n ->
53
+
assert ((Lwt_dllist.get n) = array_values.(!index));
54
+
index := (!index + 1)) seq;
55
+
Lwt.return_true)
56
+
(function _ -> Lwt.return_false)
57
+
58
+
let test_iter_rem iter_f array_values seq =
59
+
let index = ref 0 in
60
+
Lwt.catch
61
+
(fun () ->
62
+
iter_f (fun n ->
63
+
assert ((Lwt_dllist.get n) = array_values.(!index));
64
+
Lwt_dllist.remove n;
65
+
index := (!index + 1)) seq;
66
+
Lwt.return_true)
67
+
(function _ -> Lwt.return_false)
68
+
69
+
let suite = suite "lwt_sequence" [
70
+
71
+
test "create" begin fun () ->
72
+
let s = Lwt_dllist.create () in
73
+
let _ = assert (Lwt_dllist.is_empty s) in
74
+
let len = Lwt_dllist.length s in
75
+
Lwt.return (len = 0)
76
+
end;
77
+
78
+
test "add_l" begin fun () ->
79
+
let s = Lwt_dllist.create () in
80
+
let n = Lwt_dllist.add_l 1 s in
81
+
let _ = assert ((Lwt_dllist.get n) = 1) in
82
+
let len = Lwt_dllist.length s in
83
+
Lwt.return (len = 1)
84
+
end;
85
+
86
+
test "add_r" begin fun () ->
87
+
let s = Lwt_dllist.create () in
88
+
let n = Lwt_dllist.add_r 1 s in
89
+
let _ = assert ((Lwt_dllist.get n) = 1) in
90
+
let len = Lwt_dllist.length s in
91
+
Lwt.return (len = 1)
92
+
end;
93
+
94
+
test "take_l Empty" begin fun () ->
95
+
let s = Lwt_dllist.create () in
96
+
Lwt.catch
97
+
(fun () ->
98
+
let _ = Lwt_dllist.take_l s in
99
+
Lwt.return_false)
100
+
(function
101
+
| Lwt_dllist.Empty -> Lwt.return_true
102
+
| _ -> Lwt.return_false)
103
+
end;
104
+
105
+
test "take_l" begin fun () ->
106
+
let s = filled_sequence () in
107
+
Lwt.catch
108
+
(fun () ->
109
+
let v = Lwt_dllist.take_l s in
110
+
Lwt.return (leftmost_value = v))
111
+
(function _ -> Lwt.return_false)
112
+
end;
113
+
114
+
test "take_r Empty" begin fun () ->
115
+
let s = Lwt_dllist.create () in
116
+
Lwt.catch
117
+
(fun () ->
118
+
let _ = Lwt_dllist.take_r s in Lwt.return_false)
119
+
(function
120
+
| Lwt_dllist.Empty -> Lwt.return_true
121
+
| _ -> Lwt.return_false)
122
+
end;
123
+
124
+
test "take_r" begin fun () ->
125
+
let s = filled_sequence () in
126
+
Lwt.catch
127
+
(fun () ->
128
+
let v = Lwt_dllist.take_r s in Lwt.return (rightmost_value = v))
129
+
(function _ -> Lwt.return_false)
130
+
end;
131
+
132
+
test "take_opt_l Empty" begin fun () ->
133
+
let s = Lwt_dllist.create () in
134
+
match Lwt_dllist.take_opt_l s with
135
+
| None -> Lwt.return_true
136
+
| _ -> Lwt.return_false
137
+
end;
138
+
139
+
test "take_opt_l" begin fun () ->
140
+
let s = filled_sequence () in
141
+
match Lwt_dllist.take_opt_l s with
142
+
| None -> Lwt.return_false
143
+
| Some v -> Lwt.return (leftmost_value = v)
144
+
end;
145
+
146
+
test "take_opt_r Empty" begin fun () ->
147
+
let s = Lwt_dllist.create () in
148
+
match Lwt_dllist.take_opt_r s with
149
+
| None -> Lwt.return_true
150
+
| _ -> Lwt.return_false
151
+
end;
152
+
153
+
test "take_opt_r" begin fun () ->
154
+
let s = filled_sequence () in
155
+
match Lwt_dllist.take_opt_r s with
156
+
| None -> Lwt.return_false
157
+
| Some v -> Lwt.return (rightmost_value = v)
158
+
end;
159
+
160
+
test "transfer_l Empty" begin fun () ->
161
+
let s = filled_sequence () in
162
+
let ts = Lwt_dllist.create () in
163
+
let _ = Lwt_dllist.transfer_l ts s in
164
+
let len = Lwt_dllist.length s in
165
+
Lwt.return (filled_length = len)
166
+
end;
167
+
168
+
test "transfer_l " begin fun () ->
169
+
let s = filled_sequence () in
170
+
let ts = transfer_sequence () in
171
+
let _ = Lwt_dllist.transfer_l ts s in
172
+
let len = Lwt_dllist.length s in
173
+
let _ = assert ((filled_length + transfer_length) = len) in
174
+
match Lwt_dllist.take_opt_l s with
175
+
| None -> Lwt.return_false
176
+
| Some v -> Lwt.return (7 = v)
177
+
end;
178
+
179
+
test "transfer_r Empty" begin fun () ->
180
+
let s = filled_sequence () in
181
+
let ts = Lwt_dllist.create () in
182
+
let _ = Lwt_dllist.transfer_r ts s in
183
+
let len = Lwt_dllist.length s in
184
+
Lwt.return (filled_length = len)
185
+
end;
186
+
187
+
test "transfer_r " begin fun () ->
188
+
let s = filled_sequence () in
189
+
let ts = transfer_sequence () in
190
+
let _ = Lwt_dllist.transfer_r ts s in
191
+
let len = Lwt_dllist.length s in
192
+
let _ = assert ((filled_length + transfer_length) = len) in
193
+
match Lwt_dllist.take_opt_r s with
194
+
| None -> Lwt.return_false
195
+
| Some v -> Lwt.return (8 = v)
196
+
end;
197
+
198
+
test "iter_l Empty" begin fun () ->
199
+
test_iter Lwt_dllist.iter_l empty_array (Lwt_dllist.create ())
200
+
end;
201
+
202
+
test "iter_l" begin fun () ->
203
+
test_iter Lwt_dllist.iter_l l_filled_array (filled_sequence ())
204
+
end;
205
+
206
+
test "iter_r Empty" begin fun () ->
207
+
test_iter Lwt_dllist.iter_r empty_array (Lwt_dllist.create ())
208
+
end;
209
+
210
+
test "iter_r" begin fun () ->
211
+
test_iter Lwt_dllist.iter_r r_filled_array (filled_sequence ())
212
+
end;
213
+
214
+
test "iter_node_l Empty" begin fun () ->
215
+
test_iter_node Lwt_dllist.iter_node_l empty_array (Lwt_dllist.create ())
216
+
end;
217
+
218
+
test "iter_node_l" begin fun () ->
219
+
test_iter_node Lwt_dllist.iter_node_l l_filled_array (filled_sequence ())
220
+
end;
221
+
222
+
test "iter_node_r Empty" begin fun () ->
223
+
test_iter_node Lwt_dllist.iter_node_r empty_array (Lwt_dllist.create ())
224
+
end;
225
+
226
+
test "iter_node_r" begin fun () ->
227
+
test_iter_node Lwt_dllist.iter_node_r r_filled_array (filled_sequence ())
228
+
end;
229
+
230
+
test "iter_node_l with removal" begin fun () ->
231
+
test_iter_rem Lwt_dllist.iter_node_l l_filled_array (filled_sequence ())
232
+
end;
233
+
234
+
test "iter_node_r with removal" begin fun () ->
235
+
test_iter_rem Lwt_dllist.iter_node_r r_filled_array (filled_sequence ())
236
+
end;
237
+
238
+
test "fold_l" begin fun () ->
239
+
let acc = Lwt_dllist.fold_l (fun v e -> v * e) (filled_sequence ()) 1 in
240
+
Lwt.return (factorial_sequence = acc)
241
+
end;
242
+
243
+
test "fold_l Empty" begin fun () ->
244
+
let acc = Lwt_dllist.fold_l (fun v e -> v * e) (Lwt_dllist.create ()) 1 in
245
+
Lwt.return (acc = 1)
246
+
end;
247
+
248
+
test "fold_r" begin fun () ->
249
+
let acc = Lwt_dllist.fold_r (fun v e -> v * e) (filled_sequence ()) 1 in
250
+
Lwt.return (factorial_sequence = acc)
251
+
end;
252
+
253
+
test "fold_r Empty" begin fun () ->
254
+
let acc = Lwt_dllist.fold_r (fun v e -> v * e) (Lwt_dllist.create ()) 1 in
255
+
Lwt.return (acc = 1)
256
+
end;
257
+
258
+
test "find_node_opt_l Empty" begin fun () ->
259
+
let s = Lwt_dllist.create () in
260
+
match Lwt_dllist.find_node_opt_l (fun v -> v = 1) s with
261
+
| None -> Lwt.return_true
262
+
| _ -> Lwt.return_false
263
+
end;
264
+
265
+
test "find_node_opt_l not found " begin fun () ->
266
+
let s = transfer_sequence () in
267
+
match Lwt_dllist.find_node_opt_l (fun v -> v = 1) s with
268
+
| None -> Lwt.return_true
269
+
| _ -> Lwt.return_false
270
+
end;
271
+
272
+
test "find_node_opt_l" begin fun () ->
273
+
let s = filled_sequence () in
274
+
match Lwt_dllist.find_node_opt_l (fun v -> v = 1) s with
275
+
| None -> Lwt.return_false
276
+
| Some n -> if ((Lwt_dllist.get n) = 1) then Lwt.return_true
277
+
else Lwt.return_false
278
+
end;
279
+
280
+
test "find_node_opt_r Empty" begin fun () ->
281
+
let s = Lwt_dllist.create () in
282
+
match Lwt_dllist.find_node_opt_r (fun v -> v = 1) s with
283
+
| None -> Lwt.return_true
284
+
| _ -> Lwt.return_false
285
+
end;
286
+
287
+
test "find_node_opt_r not found " begin fun () ->
288
+
let s = transfer_sequence () in
289
+
match Lwt_dllist.find_node_opt_r (fun v -> v = 1) s with
290
+
| None -> Lwt.return_true
291
+
| _ -> Lwt.return_false
292
+
end;
293
+
294
+
test "find_node_opt_r" begin fun () ->
295
+
let s = filled_sequence () in
296
+
match Lwt_dllist.find_node_opt_r (fun v -> v = 1) s with
297
+
| None -> Lwt.return_false
298
+
| Some n -> if ((Lwt_dllist.get n) = 1) then Lwt.return_true
299
+
else Lwt.return_false
300
+
end;
301
+
302
+
test "find_node_l Empty" begin fun () ->
303
+
let s = Lwt_dllist.create () in
304
+
Lwt.catch
305
+
(fun () -> let n = Lwt_dllist.find_node_l (fun v -> v = 1) s in
306
+
if ((Lwt_dllist.get n) = 1) then Lwt.return_false
307
+
else Lwt.return_false)
308
+
(function
309
+
| Not_found -> Lwt.return_true
310
+
| _ -> Lwt.return_false)
311
+
end;
312
+
313
+
test "find_node_l" begin fun () ->
314
+
let s = filled_sequence () in
315
+
Lwt.catch
316
+
(fun () -> let n = Lwt_dllist.find_node_l (fun v -> v = 1) s in
317
+
if ((Lwt_dllist.get n) = 1) then Lwt.return_true
318
+
else Lwt.return_false)
319
+
(function _ -> Lwt.return_false)
320
+
end;
321
+
322
+
test "find_node_r Empty" begin fun () ->
323
+
let s = Lwt_dllist.create () in
324
+
Lwt.catch
325
+
(fun () -> let n = Lwt_dllist.find_node_r (fun v -> v = 1) s in
326
+
if ((Lwt_dllist.get n) = 1) then Lwt.return_false
327
+
else Lwt.return_false)
328
+
(function
329
+
| Not_found -> Lwt.return_true
330
+
| _ -> Lwt.return_false)
331
+
end;
332
+
333
+
test "find_node_r" begin fun () ->
334
+
let s = filled_sequence () in
335
+
Lwt.catch
336
+
(fun () -> let n = Lwt_dllist.find_node_r (fun v -> v = 1) s in
337
+
if ((Lwt_dllist.get n) = 1) then Lwt.return_true
338
+
else Lwt.return_false)
339
+
(function _ -> Lwt.return_false)
340
+
end;
341
+
342
+
test "set" begin fun () ->
343
+
let s = filled_sequence () in
344
+
match Lwt_dllist.find_node_opt_l (fun v -> v = 4) s with
345
+
| None -> Lwt.return_false
346
+
| Some n -> let _ = Lwt_dllist.set n 10 in
347
+
let data = [|1; 2; 3; 10; 5; 6|] in
348
+
test_iter Lwt_dllist.iter_l data s
349
+
end;
350
+
351
+
test "fold_r with multiple removal" begin fun () ->
352
+
let s = filled_sequence () in
353
+
let n_three = Lwt_dllist.find_node_r (fun v' -> v' = 3) s in
354
+
let n_two = Lwt_dllist.find_node_r (fun v' -> v' = 2) s in
355
+
let n_four = Lwt_dllist.find_node_r (fun v' -> v' = 4) s in
356
+
let acc = Lwt_dllist.fold_r begin fun v e ->
357
+
if v = 3 then begin
358
+
let _ = Lwt_dllist.remove n_three in
359
+
let _ = Lwt_dllist.remove n_two in
360
+
ignore(Lwt_dllist.remove n_four)
361
+
end;
362
+
v * e
363
+
end s 1 in
364
+
Lwt.return (acc = (factorial_sequence / 2))
365
+
end;
366
+
367
+
test "fold_l multiple removal" begin fun () ->
368
+
let s = filled_sequence () in
369
+
let n_four = Lwt_dllist.find_node_r (fun v' -> v' = 4) s in
370
+
let n_five = Lwt_dllist.find_node_r (fun v' -> v' = 5) s in
371
+
let n_three = Lwt_dllist.find_node_r (fun v' -> v' = 3) s in
372
+
let acc = Lwt_dllist.fold_l begin fun v e ->
373
+
if v = 4 then begin
374
+
let _ = Lwt_dllist.remove n_four in
375
+
let _ = Lwt_dllist.remove n_five in
376
+
ignore(Lwt_dllist.remove n_three)
377
+
end;
378
+
v * e
379
+
end s 1 in
380
+
Lwt.return (acc = (factorial_sequence / 5))
381
+
end;
382
+
383
+
test "find_node_r with multiple removal" begin fun () ->
384
+
let s = filled_sequence () in
385
+
let n_three = Lwt_dllist.find_node_r (fun v' -> v' = 3) s in
386
+
let n_two = Lwt_dllist.find_node_r (fun v' -> v' = 2) s in
387
+
Lwt.catch
388
+
begin fun () ->
389
+
let n = Lwt_dllist.find_node_r begin fun v ->
390
+
if v = 3 then (
391
+
let _ = Lwt_dllist.remove n_three in
392
+
ignore(Lwt_dllist.remove n_two));
393
+
v = 1
394
+
end s in
395
+
let v = Lwt_dllist.get n in
396
+
Lwt.return (v = 1)
397
+
end
398
+
(function _ -> Lwt.return_false)
399
+
end;
400
+
401
+
test "find_node_l with multiple removal" begin fun () ->
402
+
let s = filled_sequence () in
403
+
let n_three = Lwt_dllist.find_node_r (fun v' -> v' = 3) s in
404
+
let n_four = Lwt_dllist.find_node_r (fun v' -> v' = 4) s in
405
+
Lwt.catch
406
+
begin fun () ->
407
+
let n = Lwt_dllist.find_node_l begin fun v ->
408
+
if v = 3 then (
409
+
let _ = Lwt_dllist.remove n_three in
410
+
ignore(Lwt_dllist.remove n_four));
411
+
v = 6 end s in
412
+
let v = Lwt_dllist.get n in
413
+
Lwt.return (v = 6)
414
+
end
415
+
(function _ -> Lwt.return_false)
416
+
end;
417
+
]