Source file stable_unit_test.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
open! Import
open Std_internal
include Stable_unit_test_intf
module Make_sexp_deserialization_test (T : Stable_unit_test_intf.Arg) = struct
let%test_unit "sexp deserialization" =
Or_error.combine_errors_unit
(List.map T.tests ~f:(fun (t, sexp_as_string, _) ->
match
Or_error.try_with (fun () ->
sexp_as_string |> Sexp.of_string |> [%of_sexp: T.t])
with
| Error _ as error ->
Or_error.tag_arg
error
"could not deserialize sexp"
(sexp_as_string, `Expected t)
[%sexp_of: string * [ `Expected of T.t ]]
| Ok t' ->
if T.equal t t'
then Ok ()
else
Or_error.error
"sexp deserialization mismatch"
(`Expected t, `But_got t')
[%sexp_of: [ `Expected of T.t ] * [ `But_got of T.t ]]))
|> ok_exn
;;
end
module Make_sexp_serialization_test (T : Stable_unit_test_intf.Arg) = struct
let%test_unit "sexp serialization" =
Or_error.combine_errors_unit
(List.map T.tests ~f:(fun (t, sexp_as_string, _) ->
Or_error.try_with (fun () ->
let sexp = Sexp.of_string sexp_as_string in
let serialized_sexp = T.sexp_of_t t in
if Sexp.( <> ) serialized_sexp sexp
then
failwiths
~here:[%here]
"sexp serialization mismatch"
(`Expected sexp, `But_got serialized_sexp)
[%sexp_of: [ `Expected of Sexp.t ] * [ `But_got of Sexp.t ]])))
|> ok_exn
;;
end
module Make_bin_io_test (T : Stable_unit_test_intf.Arg) = struct
let%test_unit "bin_io" =
List.iter T.tests ~f:(fun (t, _, expected_bin_io) ->
let binable_m = (module T : Binable.S with type t = T.t) in
let to_bin_string t = Binable.to_string binable_m t in
let serialized_bin_io = to_bin_string t in
if String.( <> ) serialized_bin_io expected_bin_io
then
failwiths
~here:[%here]
"bin_io serialization mismatch"
(t, `Expected expected_bin_io, `But_got serialized_bin_io)
[%sexp_of: T.t * [ `Expected of string ] * [ `But_got of string ]];
let t' = Binable.of_string binable_m serialized_bin_io in
if not (T.equal t t')
then
failwiths
~here:[%here]
"bin_io deserialization mismatch"
(`Expected t, `But_got t')
[%sexp_of: [ `Expected of T.t ] * [ `But_got of T.t ]])
;;
end
module Make (T : Stable_unit_test_intf.Arg) = struct
include Make_sexp_deserialization_test (T)
include Make_sexp_serialization_test (T)
include Make_bin_io_test (T)
end
module Make_unordered_container (T : Stable_unit_test_intf.Unordered_container_arg) =
struct
module Test = Stable_unit_test_intf.Unordered_container_test
let%test_unit "sexp" =
List.iter T.tests ~f:(fun (t, { Test.sexps; _ }) ->
let sexps = List.map sexps ~f:Sexp.of_string in
let serialized_elements =
match T.sexp_of_t t with
| Sexp.List sexps -> sexps
| Sexp.Atom _ ->
failwiths
~here:[%here]
"expected list when serializing unordered container"
t
T.sexp_of_t
in
let sorted_sexps = List.sort ~compare:Sexp.compare sexps in
let sorted_serialized = List.sort ~compare:Sexp.compare serialized_elements in
if not (List.equal Sexp.( = ) sorted_sexps sorted_serialized)
then
failwiths
~here:[%here]
"sexp serialization mismatch"
(`Expected sexps, `But_got serialized_elements)
[%sexp_of: [ `Expected of Sexp.t list ] * [ `But_got of Sexp.t list ]];
let sexp_permutations = List.init 10 ~f:(fun _ -> List.permute sexps) in
List.iter sexp_permutations ~f:(fun sexps ->
let t' = T.t_of_sexp (Sexp.List sexps) in
if not (T.equal t t')
then
failwiths
~here:[%here]
"sexp deserialization msimatch"
(`Expected t, `But_got t')
[%sexp_of: [ `Expected of T.t ] * [ `But_got of T.t ]]))
;;
let rec is_concatenation string strings =
if String.is_empty string
then List.for_all strings ~f:String.is_empty
else (
let rec loop rev_skipped strings =
match strings with
| [] -> false
| prefix :: strings ->
let continue () = loop (prefix :: rev_skipped) strings in
(match String.chop_prefix ~prefix string with
| None -> continue ()
| Some string ->
is_concatenation string (List.rev_append rev_skipped strings) || continue ())
in
loop [] strings)
;;
let%test_unit "bin_io" =
List.iter T.tests ~f:(fun (t, { Test.bin_io_header; bin_io_elements; _ }) ->
let binable_m = (module T : Binable.S with type t = T.t) in
let elements = bin_io_elements in
let bin_io_of_elements elements = bin_io_header ^ String.concat elements in
let serialized = Binable.to_string binable_m t in
let serialization_matches =
match String.chop_prefix ~prefix:bin_io_header serialized with
| None -> false
| Some elements_string -> is_concatenation elements_string elements
in
if not serialization_matches
then
failwiths
~here:[%here]
"serialization mismatch"
(`Expected (bin_io_header, elements), `But_got serialized)
[%sexp_of: [ `Expected of string * string list ] * [ `But_got of string ]];
let permutatations = List.init 10 ~f:(fun _ -> List.permute elements) in
List.iter permutatations ~f:(fun elements ->
let t' = Binable.of_string binable_m (bin_io_of_elements elements) in
if not (T.equal t t')
then
failwiths
~here:[%here]
"bin-io deserialization mismatch"
(`Expected t, `But_got t')
[%sexp_of: [ `Expected of T.t ] * [ `But_got of T.t ]]))
;;
end