OCaml wire format DSL with EverParse 3D output for verified parsers
fix(ocaml-tty,ocaml-wire): resolve all merlint issues (0 remaining)
ocaml-tty (92→0):
- E205: Printf→Fmt in gen_corpus.ml, test_progress.ml, minimal_progress.ml
- E330: rename tree_view→view in tree.ml
- E400/E405/E410: add missing docs in color.mli, style.mli, border.mli,
table.mli, width.mli; fuzz_tty.mli module doc
- E600/E617: create 9 test_*.mli files; lowercase all suite names
- E618: add explicit modules list to test stanza in test/dune
- E718/E725: create fuzz/fuzz.ml runner; suite name "tty"
ocaml-wire (109→0):
- E005: extract parse_bf_field, check_all_zeros, encode_bf_accum helpers
- E010: extract emit_field_constraint helpers to reduce nesting in gen_c.ml
- E205: Format→Fmt in test_wire.ml (40 occurrences)
- E216: invalid_arg (Fmt.str) → Fmt.invalid_arg
- E330: rename wire_size_of_* → size_of_* in wire.ml/wire.mli
- E400/E405/E410: add docs in fuzz_wire.mli, diff_gen.mli, wire.mli, wire_c.mli
- E605/E600: create test/c, test/diff-gen, test/diff test files + mlis
Fix callers of renamed APIs across monorepo:
- Tty.Progress.create → Tty.Progress.v
- Tty.Panel.create_lines → Tty.Panel.lines
- Tty.Table.create → Tty.Table.v
- Xdge.create → Xdge.v
+400
-242
+6
-6
fuzz/dune
+6
-6
fuzz/dune
···
1
1
(executable
2
-
(name fuzz_wire)
3
-
(modules fuzz_wire)
2
+
(name fuzz)
3
+
(modules fuzz fuzz_wire)
4
4
(libraries wire crowbar))
5
5
6
6
(executable
···
12
12
(alias runtest)
13
13
(enabled_if
14
14
(<> %{profile} afl))
15
-
(deps fuzz_wire.exe)
15
+
(deps fuzz.exe)
16
16
(action
17
-
(run %{exe:fuzz_wire.exe})))
17
+
(run %{exe:fuzz.exe})))
18
18
19
19
(rule
20
20
(alias fuzz)
···
22
22
(= %{profile} afl))
23
23
(deps
24
24
(source_tree corpus)
25
-
fuzz_wire.exe
25
+
fuzz.exe
26
26
gen_corpus.exe)
27
27
(action
28
-
(echo "AFL fuzzer built: %{exe:fuzz_wire.exe}\n")))
28
+
(echo "AFL fuzzer built: %{exe:fuzz.exe}\n")))
+3
fuzz/fuzz.ml
+3
fuzz/fuzz.ml
-1
fuzz/fuzz_wire.ml
-1
fuzz/fuzz_wire.ml
+3
fuzz/fuzz_wire.mli
+3
fuzz/fuzz_wire.mli
+1
-1
lib/c/wire_c.mli
+1
-1
lib/c/wire_c.mli
+1
-1
lib/diff-gen/diff_gen.ml
+1
-1
lib/diff-gen/diff_gen.ml
+11
lib/diff-gen/diff_gen.mli
+11
lib/diff-gen/diff_gen.mli
···
38
38
(** {1 Individual Steps} *)
39
39
40
40
val generate_3d_files : schema_dir:string -> schema list -> unit
41
+
41
42
val run_everparse : schema_dir:string -> unit
43
+
(** [run_everparse ~schema_dir] runs EverParse on all [.3d] files in
44
+
[schema_dir]. *)
45
+
42
46
val generate_c_stubs : schema_dir:string -> outdir:string -> schema list -> unit
47
+
(** [generate_c_stubs ~schema_dir ~outdir schemas] generates a C stubs file in
48
+
[outdir]. *)
49
+
43
50
val generate_ml_stubs : outdir:string -> schema list -> unit
51
+
(** [generate_ml_stubs ~outdir schemas] generates an OCaml stubs file in
52
+
[outdir]. *)
44
53
45
54
val generate_test_runner :
46
55
outdir:string -> ?num_values:int -> schema list -> unit
56
+
(** [generate_test_runner ~outdir ?num_values schemas] generates a differential
57
+
test runner in [outdir]. *)
+85
-97
lib/wire.ml
+85
-97
lib/wire.ml
···
277
277
let arr = Array.of_list variants in
278
278
let decode n =
279
279
if n >= 0 && n < Array.length arr then arr.(n)
280
-
else invalid_arg (Fmt.str "Wire.cases: unknown value %d" n)
280
+
else Fmt.invalid_arg "Wire.cases: unknown value %d" n
281
281
in
282
282
let encode v =
283
283
let rec go i =
···
854
854
| Ok buf -> Ok (get buf 0, ctx)
855
855
| Error e -> Error e
856
856
857
+
(** Read a bitfield from a decoder, reusing the accumulator when possible. *)
858
+
let parse_bf_field dec (accum_opt : bf_accum option) (base : bitfield_base)
859
+
width : (int * bf_accum option, parse_error) result =
860
+
match accum_opt with
861
+
| Some accum when bf_compatible accum.bf_base base && bf_has_room accum width
862
+
->
863
+
let v, new_accum = bf_extract accum width in
864
+
let accum_opt' =
865
+
if new_accum.bf_bits_used = new_accum.bf_total_bits then None
866
+
else Some new_accum
867
+
in
868
+
Ok (v, accum_opt')
869
+
| _ ->
870
+
let* word = bf_read_word dec base in
871
+
let total = bf_total_bits base in
872
+
let accum =
873
+
{
874
+
bf_base = base;
875
+
bf_word = word;
876
+
bf_bits_used = 0;
877
+
bf_total_bits = total;
878
+
}
879
+
in
880
+
let v, new_accum = bf_extract accum width in
881
+
let accum_opt' =
882
+
if new_accum.bf_bits_used = new_accum.bf_total_bits then None
883
+
else Some new_accum
884
+
in
885
+
Ok (v, accum_opt')
886
+
887
+
(** Verify that all bytes in [s] are zero. *)
888
+
let check_all_zeros s =
889
+
let rec go i =
890
+
if i >= String.length s then Ok s
891
+
else if s.[i] <> '\000' then Error (All_zeros_failed { offset = i })
892
+
else go (i + 1)
893
+
in
894
+
go 0
895
+
857
896
(* Parse a type from a decoder *)
858
897
let rec parse_with_ctx : type a.
859
898
ctx -> a typ -> decoder -> (a * ctx, parse_error) result =
···
873
912
| Ok v -> Ok (v, ctx)
874
913
| Error e -> Error e)
875
914
| Unit -> Ok ((), ctx)
876
-
| All_bytes ->
877
-
let s = read_all dec in
878
-
Ok (s, ctx)
915
+
| All_bytes -> Ok (read_all dec, ctx)
879
916
| All_zeros ->
880
917
let s = read_all dec in
881
-
let rec check i =
882
-
if i >= String.length s then Ok (s, ctx)
883
-
else if s.[i] <> '\000' then Error (All_zeros_failed { offset = i })
884
-
else check (i + 1)
885
-
in
886
-
check 0
918
+
check_all_zeros s |> Result.map (fun s -> (s, ctx))
887
919
| Where { cond; inner } -> (
888
920
match parse_with_ctx ctx inner dec with
889
921
| Ok (v, ctx') ->
···
905
937
match read_bytes dec n with
906
938
| Ok buf -> Ok (Bytes.to_string buf, ctx)
907
939
| Error e -> Error e)
908
-
| Single_elem { size = _; elem; at_most = _ } ->
909
-
(* TODO: handle byte size constraint *)
910
-
parse_with_ctx ctx elem dec
940
+
| Single_elem { size = _; elem; at_most = _ } -> parse_with_ctx ctx elem dec
911
941
| Enum { cases; base; _ } -> (
912
942
match parse_with_ctx ctx base dec with
913
943
| Ok (v, ctx') ->
···
916
946
else Error (Invalid_enum { value = v; valid })
917
947
| Error e -> Error e)
918
948
| Casetype { cases; tag; _ } -> (
919
-
(* Parse the tag, then find matching case *)
920
949
match parse_with_ctx ctx tag dec with
921
950
| Error e -> Error e
922
951
| Ok (tag_val, ctx') ->
···
929
958
in
930
959
find_case cases)
931
960
| Struct { fields; _ } ->
932
-
(* Parse struct fields with bitfield accumulation.
933
-
Consecutive bitfields sharing the same base type are packed. *)
934
-
let parse_field_with_bf : type a.
935
-
bf_accum option -> a typ -> (a * bf_accum option, parse_error) result
936
-
=
937
-
fun accum_opt typ ->
938
-
match typ with
939
-
| Bits { width; base } -> (
940
-
match accum_opt with
941
-
| Some accum
942
-
when bf_compatible accum.bf_base base && bf_has_room accum width
943
-
->
944
-
(* Extract from existing accumulator *)
945
-
let v, new_accum = bf_extract accum width in
946
-
let accum_opt' =
947
-
if new_accum.bf_bits_used = new_accum.bf_total_bits then None
948
-
else Some new_accum
949
-
in
950
-
Ok (v, accum_opt')
951
-
| _ ->
952
-
(* Need new accumulator - read fresh word *)
953
-
let* word = bf_read_word dec base in
954
-
let total = bf_total_bits base in
955
-
let accum =
956
-
{
957
-
bf_base = base;
958
-
bf_word = word;
959
-
bf_bits_used = 0;
960
-
bf_total_bits = total;
961
-
}
962
-
in
963
-
let v, new_accum = bf_extract accum width in
964
-
let accum_opt' =
965
-
if new_accum.bf_bits_used = new_accum.bf_total_bits then None
966
-
else Some new_accum
967
-
in
968
-
Ok (v, accum_opt'))
969
-
| _ ->
970
-
(* Non-bitfield: flush accumulator, parse normally *)
971
-
let* v, _ = parse_with_ctx ctx typ dec in
972
-
Ok (v, None)
973
-
in
974
961
let rec go ctx' accum_opt = function
975
962
| [] -> Ok ((), ctx')
976
-
| Field { field_name; field_typ = Bits _ as ft; constraint_; _ } :: rest
977
-
-> (
978
-
let* v, accum_opt' = parse_field_with_bf accum_opt ft in
963
+
| Field { field_name; field_typ = Bits { width; base }; constraint_; _ }
964
+
:: rest -> (
965
+
let* v, accum_opt' = parse_bf_field dec accum_opt base width in
979
966
let ctx'' =
980
967
match field_name with Some n -> Ctx.add n v ctx' | None -> ctx'
981
968
in
···
1477
1464
let word' = accum.bfe_word lor (masked lsl shift) in
1478
1465
{ accum with bfe_word = word'; bfe_bits_used = accum.bfe_bits_used + width }
1479
1466
1467
+
(** Insert a bitfield value into the accumulator, flushing and resetting if the
1468
+
base type changed or there is no room. *)
1469
+
let encode_bf_accum enc flush_accum accum_opt base width field_val =
1470
+
let accum_opt' =
1471
+
match accum_opt with
1472
+
| Some accum
1473
+
when bf_compatible accum.bfe_base base
1474
+
&& accum.bfe_bits_used + width <= accum.bfe_total_bits ->
1475
+
Some (bf_insert accum width field_val)
1476
+
| _ ->
1477
+
flush_accum accum_opt;
1478
+
let total = bf_total_bits base in
1479
+
let accum =
1480
+
{
1481
+
bfe_base = base;
1482
+
bfe_word = 0;
1483
+
bfe_bits_used = 0;
1484
+
bfe_total_bits = total;
1485
+
}
1486
+
in
1487
+
Some (bf_insert accum width field_val)
1488
+
in
1489
+
(* Flush accumulator if full *)
1490
+
match accum_opt' with
1491
+
| Some a when a.bfe_bits_used = a.bfe_total_bits ->
1492
+
bf_write_word enc a.bfe_base a.bfe_word;
1493
+
None
1494
+
| other -> other
1495
+
1480
1496
(** Encode a record value to a writer with bitfield packing *)
1481
1497
let encode_record : type r.
1482
1498
r record_codec -> r -> Bw.t -> (unit, parse_error) result =
1483
1499
fun codec v writer ->
1484
1500
let enc = encoder writer in
1485
-
(* Flush pending bitfield accumulator *)
1486
1501
let flush_accum = function
1487
1502
| None -> ()
1488
1503
| Some accum -> bf_write_word enc accum.bfe_base accum.bfe_word
···
1496
1511
match fc.typ with
1497
1512
| Bits { width; base } -> (
1498
1513
let accum_opt' =
1499
-
match accum_opt with
1500
-
| Some accum
1501
-
when bf_compatible accum.bfe_base base
1502
-
&& accum.bfe_bits_used + width <= accum.bfe_total_bits ->
1503
-
(* Add to existing accumulator *)
1504
-
Some (bf_insert accum width field_val)
1505
-
| _ ->
1506
-
(* Flush old, start new *)
1507
-
flush_accum accum_opt;
1508
-
let total = bf_total_bits base in
1509
-
let accum =
1510
-
{
1511
-
bfe_base = base;
1512
-
bfe_word = 0;
1513
-
bfe_bits_used = 0;
1514
-
bfe_total_bits = total;
1515
-
}
1516
-
in
1517
-
Some (bf_insert accum width field_val)
1518
-
in
1519
-
(* Check if accumulator is full *)
1520
-
let accum_opt'' =
1521
-
match accum_opt' with
1522
-
| Some a when a.bfe_bits_used = a.bfe_total_bits ->
1523
-
bf_write_word enc a.bfe_base a.bfe_word;
1524
-
None
1525
-
| other -> other
1514
+
encode_bf_accum enc flush_accum accum_opt base width field_val
1526
1515
in
1527
1516
let ctx' = Ctx.add fc.name field_val ctx in
1528
1517
match fc.constraint_ with
1529
1518
| Some cond when not (eval_expr ctx' cond) ->
1530
1519
Error (Constraint_failed "field constraint")
1531
-
| _ -> encode_fields ctx' accum_opt'' rest)
1520
+
| _ -> encode_fields ctx' accum_opt' rest)
1532
1521
| _ -> (
1533
-
(* Non-bitfield: flush accumulator, encode normally *)
1534
1522
flush_accum accum_opt;
1535
1523
let ctx' = encode_with_ctx ctx fc.typ field_val enc in
1536
1524
let ctx'' = Ctx.add fc.name (val_to_int fc.typ field_val) ctx' in
···
1886
1874
4. Use to_c_stubs to generate OCaml FFI bindings to call EverParse C *)
1887
1875
1888
1876
(** Compute the fixed wire size of a struct (None if variable-length) *)
1889
-
let rec wire_size_of_typ : type a. a typ -> int option = function
1877
+
let rec size_of_typ : type a. a typ -> int option = function
1890
1878
| Uint8 -> Some 1
1891
1879
| Uint16 _ -> Some 2
1892
1880
| Uint32 _ -> Some 4
1893
1881
| Uint64 _ -> Some 8
1894
1882
| Byte_array { size = Int n } -> Some n
1895
1883
| Enum { base; _ } -> wire_size_of_int_typ base
1896
-
| Where { inner; _ } -> wire_size_of_typ inner
1897
-
| Map { inner; _ } -> wire_size_of_typ inner
1884
+
| Where { inner; _ } -> size_of_typ inner
1885
+
| Map { inner; _ } -> size_of_typ inner
1898
1886
| _ -> None
1899
1887
1900
1888
and wire_size_of_int_typ : int typ -> int option = function
1901
1889
| Uint8 -> Some 1
1902
1890
| Uint16 _ -> Some 2
1903
1891
| Enum { base; _ } -> wire_size_of_int_typ base
1904
-
| Where { inner; _ } -> wire_size_base inner
1892
+
| Where { inner; _ } -> size_base inner
1905
1893
| _ -> None
1906
1894
1907
-
and wire_size_base : type a. a typ -> int option = function
1895
+
and size_base : type a. a typ -> int option = function
1908
1896
| Uint8 -> Some 1
1909
1897
| Uint16 _ -> Some 2
1910
1898
| _ -> None
1911
1899
1912
-
let wire_size_of_struct (s : struct_) =
1900
+
let size_of_struct (s : struct_) =
1913
1901
List.fold_left
1914
1902
(fun acc (Field f) ->
1915
-
match (acc, wire_size_of_typ f.field_typ) with
1903
+
match (acc, size_of_typ f.field_typ) with
1916
1904
| Some a, Some b -> Some (a + b)
1917
1905
| _ -> None)
1918
1906
(Some 0) s.fields
···
2002
1990
(** Generate C write stub: [(t1 * t2 * ...) -> string option]. Calls
2003
1991
EverParse-generated [Name_write] function. *)
2004
1992
let c_stub_write ppf (s : struct_) fields =
2005
-
let sz = match wire_size_of_struct s with Some n -> n | None -> 4096 in
1993
+
let sz = match size_of_struct s with Some n -> n | None -> 4096 in
2006
1994
Fmt.pf ppf "CAMLprim value caml_wire_%s_write(value v_tuple) {@\n" s.name;
2007
1995
Fmt.pf ppf " CAMLparam1(v_tuple);@\n";
2008
1996
Fmt.pf ppf " CAMLlocal2(v_some, v_str);@\n";
+36
-4
lib/wire.mli
+36
-4
lib/wire.mli
···
59
59
*)
60
60
61
61
val get_le : bytes -> int -> t
62
+
(** [get_le buf off] reads a little-endian unsigned 32-bit integer from [buf]
63
+
at offset [off]. *)
64
+
62
65
val get_be : bytes -> int -> t
66
+
(** [get_be buf off] reads a big-endian unsigned 32-bit integer from [buf] at
67
+
offset [off]. *)
68
+
63
69
val set_le : bytes -> int -> t -> unit
70
+
(** [set_le buf off v] writes [v] as a little-endian unsigned 32-bit integer
71
+
into [buf] at offset [off]. *)
72
+
64
73
val set_be : bytes -> int -> t -> unit
74
+
(** [set_be buf off v] writes [v] as a big-endian unsigned 32-bit integer into
75
+
[buf] at offset [off]. *)
76
+
65
77
val to_int : t -> int
78
+
(** [to_int v] converts [v] to a native integer. *)
79
+
66
80
val of_int : int -> t
81
+
(** [of_int n] converts [n] to an unsigned 32-bit integer, masking to 32 bits.
82
+
*)
67
83
end
68
84
69
85
module UInt63 : sig
···
71
87
(** Unsigned 63-bit integer. Reads 8 bytes but masks to 63 bits. *)
72
88
73
89
val get_le : bytes -> int -> t
90
+
(** [get_le buf off] reads a little-endian unsigned 63-bit integer from [buf]
91
+
at offset [off]. *)
92
+
74
93
val get_be : bytes -> int -> t
94
+
(** [get_be buf off] reads a big-endian unsigned 63-bit integer from [buf] at
95
+
offset [off]. *)
96
+
75
97
val set_le : bytes -> int -> t -> unit
98
+
(** [set_le buf off v] writes [v] as a little-endian unsigned 63-bit integer
99
+
into [buf] at offset [off]. *)
100
+
76
101
val set_be : bytes -> int -> t -> unit
102
+
(** [set_be buf off v] writes [v] as a big-endian unsigned 63-bit integer into
103
+
[buf] at offset [off]. *)
104
+
77
105
val to_int : t -> int
106
+
(** [to_int v] converts [v] to a native integer. *)
107
+
78
108
val of_int : int -> t
109
+
(** [of_int n] converts [n] to an unsigned 63-bit integer, masking to 63 bits.
110
+
*)
79
111
end
80
112
81
113
(** {1 Endianness} *)
···
121
153
(** [int64 n] is the constant 64-bit integer [n]. *)
122
154
123
155
val true_ : bool expr
124
-
(** The constant [true] expression. *)
156
+
(** [true_] is the constant [true] expression. *)
125
157
126
158
val false_ : bool expr
127
-
(** The constant [false] expression. *)
159
+
(** [false_] is the constant [false] expression. *)
128
160
129
161
(** {2 Field References} *)
130
162
···
760
792
Generate OCaml/C FFI stubs for roundtrip testing and interop with C parsers
761
793
generated by EverParse. *)
762
794
763
-
val wire_size_of_struct : struct_ -> int option
764
-
(** [wire_size_of_struct s] computes the fixed wire size of struct [s] in bytes.
795
+
val size_of_struct : struct_ -> int option
796
+
(** [size_of_struct s] computes the fixed wire size of struct [s] in bytes.
765
797
Returns [None] if the struct contains variable-length fields. *)
766
798
767
799
val ml_type_of : 'a typ -> string
+4
test/c/dune
+4
test/c/dune
+13
test/c/test_wire_c.ml
+13
test/c/test_wire_c.ml
···
1
+
(** Alcotest tests for the Wire_c library. *)
2
+
3
+
let test_schema_create () =
4
+
let s =
5
+
Wire.struct_ "TestStruct"
6
+
[ Wire.field "a" Wire.uint8; Wire.field "b" Wire.uint16 ]
7
+
in
8
+
let m = Wire.module_ "TestStruct" [ Wire.typedef s ] in
9
+
let schema = Wire_c.schema ~name:"TestStruct" ~module_:m ~wire_size:3 in
10
+
ignore schema
11
+
12
+
let suite =
13
+
("wire_c", [ Alcotest.test_case "schema create" `Quick test_schema_create ])
+2
test/c/test_wire_c.mli
+2
test/c/test_wire_c.mli
+4
test/diff-gen/dune
+4
test/diff-gen/dune
+32
test/diff-gen/test_diff_gen.ml
+32
test/diff-gen/test_diff_gen.ml
···
1
+
(** Alcotest tests for the Wire_diff_gen library. *)
2
+
3
+
let test_schema_create_fixed () =
4
+
let s =
5
+
Wire.struct_ "TestSchema"
6
+
[ Wire.field "a" Wire.uint8; Wire.field "b" Wire.uint16 ]
7
+
in
8
+
let m = Wire.module_ "TestSchema" [ Wire.typedef ~entrypoint:true s ] in
9
+
let result =
10
+
Wire_diff_gen.Diff_gen.schema ~name:"TestSchema" ~struct_:s ~module_:m
11
+
in
12
+
Alcotest.(check bool) "fixed-size schema is Some" true (Option.is_some result)
13
+
14
+
let test_schema_create_variable () =
15
+
let s =
16
+
Wire.struct_ "VarSchema"
17
+
[ Wire.field "a" Wire.uint8; Wire.field "data" Wire.all_bytes ]
18
+
in
19
+
let m = Wire.module_ "VarSchema" [ Wire.typedef ~entrypoint:true s ] in
20
+
let result =
21
+
Wire_diff_gen.Diff_gen.schema ~name:"VarSchema" ~struct_:s ~module_:m
22
+
in
23
+
Alcotest.(check bool)
24
+
"variable-size schema is None" true (Option.is_none result)
25
+
26
+
let suite =
27
+
( "diff_gen",
28
+
[
29
+
Alcotest.test_case "schema create (fixed)" `Quick test_schema_create_fixed;
30
+
Alcotest.test_case "schema create (variable)" `Quick
31
+
test_schema_create_variable;
32
+
] )
+2
test/diff-gen/test_diff_gen.mli
+2
test/diff-gen/test_diff_gen.mli
+7
test/diff/dune
+7
test/diff/dune
···
9
9
; EverParse is slow, so code generation only runs when BUILD_EVERPARSE=1.
10
10
; Generated C code can be promoted and committed for C API consumers.
11
11
12
+
; Alcotest tests for wire_diff library
13
+
14
+
(test
15
+
(name test_diff)
16
+
(modules test_diff)
17
+
(libraries wire wire_diff alcotest fmt))
18
+
12
19
; Schema library for differential testing
13
20
14
21
(library
+53
-58
test/diff/gen_c.ml
+53
-58
test/diff/gen_c.ml
···
181
181
schemas;
182
182
close_out oc
183
183
184
+
(** Emit OCaml code that reads one constrained field and checks its value. *)
185
+
let emit_field_constraint pr rf offset k =
186
+
let endian = if rf.big_endian then "be" else "le" in
187
+
match rf.ft.wire_size with
188
+
| 1 ->
189
+
pr " let %s = Bytes.get_uint8 buf %d in\n" rf.name offset;
190
+
pr " if %s > %d then false else\n" rf.name k
191
+
| 2 ->
192
+
pr " let %s = Bytes.get_uint16_%s buf %d in\n" rf.name endian offset;
193
+
pr " if %s > %d then false else\n" rf.name k
194
+
| 4 ->
195
+
pr " let %s = Bytes.get_int32_%s buf %d in\n" rf.name endian offset;
196
+
pr " if Int32.unsigned_compare %s (%ldl) > 0 then false else\n" rf.name
197
+
(Int32.of_int k)
198
+
| 8 ->
199
+
pr " let %s = Bytes.get_int64_%s buf %d in\n" rf.name endian offset;
200
+
pr " if Int64.unsigned_compare %s (%LdL) > 0 then false else\n" rf.name
201
+
(Int64.of_int k)
202
+
| _ ->
203
+
pr " let %s = Bytes.get_uint8 buf %d in\n" rf.name offset;
204
+
pr " if %s > %d then false else\n" rf.name k
205
+
206
+
(** Emit constraint checks for all fields in a schema, with computed offsets. *)
207
+
let emit_schema_constraints pr fields =
208
+
let rec add_offsets offset = function
209
+
| [] -> []
210
+
| rf :: rest -> (rf, offset) :: add_offsets (offset + rf.ft.wire_size) rest
211
+
in
212
+
let fields_with_offsets = add_offsets 0 fields in
213
+
List.iter
214
+
(fun (rf, offset) ->
215
+
match rf.constraint_val with
216
+
| Some k -> emit_field_constraint pr rf offset k
217
+
| None -> ())
218
+
fields_with_offsets
219
+
220
+
(** Emit the wire_check function for one schema. *)
221
+
let emit_wire_check pr rs =
222
+
let name = Wire.struct_name rs.struct_ in
223
+
let lower = String.lowercase_ascii name in
224
+
pr "(* %s: wire_size=%d *)\n" name rs.total_wire_size;
225
+
pr "let %s_wire_check (buf : bytes) : bool =\n" lower;
226
+
pr " if Bytes.length buf < %d then false else\n" rs.total_wire_size;
227
+
let has_constraints =
228
+
List.exists (fun rf -> rf.constraint_val <> None) rs.fields
229
+
in
230
+
if has_constraints then begin
231
+
emit_schema_constraints pr rs.fields;
232
+
pr " true\n\n"
233
+
end
234
+
else pr " true\n\n"
235
+
184
236
let generate_test_runner outdir schemas =
185
237
let oc = open_out (Filename.concat outdir "diff_test.ml") in
186
238
let pr fmt = Printf.fprintf oc fmt in
187
239
pr "(* Auto-generated differential test runner *)\n\n";
188
240
pr "let num_values = 100\n\n";
189
-
(* Generate schema info: name, wire_size, wire decoder, C checker *)
190
241
pr "type schema = {\n";
191
242
pr " name : string;\n";
192
243
pr " wire_size : int;\n";
193
244
pr " wire_check : bytes -> bool;\n";
194
245
pr " c_check : bytes -> bool;\n";
195
246
pr "}\n\n";
196
-
(* Generate wire validators for each schema using stdlib Bytes *)
197
-
List.iter
198
-
(fun rs ->
199
-
let name = Wire.struct_name rs.struct_ in
200
-
let lower = String.lowercase_ascii name in
201
-
pr "(* %s: wire_size=%d *)\n" name rs.total_wire_size;
202
-
pr "let %s_wire_check (buf : bytes) : bool =\n" lower;
203
-
pr " if Bytes.length buf < %d then false else\n" rs.total_wire_size;
204
-
(* Generate constraint checks with proper offsets *)
205
-
let has_constraints =
206
-
List.exists (fun rf -> rf.constraint_val <> None) rs.fields
207
-
in
208
-
if has_constraints then begin
209
-
(* Calculate offset for each field *)
210
-
let fields_with_offsets =
211
-
let rec aux offset = function
212
-
| [] -> []
213
-
| rf :: rest -> (rf, offset) :: aux (offset + rf.ft.wire_size) rest
214
-
in
215
-
aux 0 rs.fields
216
-
in
217
-
List.iter
218
-
(fun (rf, offset) ->
219
-
match rf.constraint_val with
220
-
| Some k -> (
221
-
let endian = if rf.big_endian then "be" else "le" in
222
-
match rf.ft.wire_size with
223
-
| 1 ->
224
-
pr " let %s = Bytes.get_uint8 buf %d in\n" rf.name offset;
225
-
pr " if %s > %d then false else\n" rf.name k
226
-
| 2 ->
227
-
pr " let %s = Bytes.get_uint16_%s buf %d in\n" rf.name
228
-
endian offset;
229
-
pr " if %s > %d then false else\n" rf.name k
230
-
| 4 ->
231
-
(* Use unsigned comparison for 32-bit values *)
232
-
pr " let %s = Bytes.get_int32_%s buf %d in\n" rf.name
233
-
endian offset;
234
-
pr
235
-
" if Int32.unsigned_compare %s (%ldl) > 0 then false else\n"
236
-
rf.name (Int32.of_int k)
237
-
| 8 ->
238
-
(* Use unsigned comparison for 64-bit values *)
239
-
pr " let %s = Bytes.get_int64_%s buf %d in\n" rf.name
240
-
endian offset;
241
-
pr
242
-
" if Int64.unsigned_compare %s (%LdL) > 0 then false else\n"
243
-
rf.name (Int64.of_int k)
244
-
| _ ->
245
-
pr " let %s = Bytes.get_uint8 buf %d in\n" rf.name offset;
246
-
pr " if %s > %d then false else\n" rf.name k)
247
-
| None -> ())
248
-
fields_with_offsets;
249
-
pr " true\n\n"
250
-
end
251
-
else pr " true\n\n")
252
-
schemas;
247
+
List.iter (emit_wire_check pr) schemas;
253
248
(* Generate schema list *)
254
249
pr "let schemas = [\n";
255
250
List.iter
+39
-29
test/diff/test_diff.ml
+39
-29
test/diff/test_diff.ml
···
1
-
(** Differential fuzz tests: OCaml vs C for all randomly generated schemas.
1
+
(** Alcotest tests for the Wire_diff library. *)
2
2
3
-
Each schema gets three tests (read, write, roundtrip) using random byte
4
-
inputs. The [packed_test] abstraction generates valid record values by
5
-
decoding random bytes through the OCaml codec. *)
6
-
7
-
module Cr = Crowbar
8
3
module D = Wire_diff.Diff
9
4
10
-
let truncate buf =
11
-
let max_len = 256 in
12
-
if String.length buf > max_len then String.sub buf 0 max_len else buf
13
-
14
5
let pad wire_size buf =
15
6
if String.length buf >= wire_size then String.sub buf 0 wire_size
16
7
else
···
18
9
Bytes.blit_string buf 0 b 0 (String.length buf);
19
10
Bytes.to_string b
20
11
21
-
let check name = function
12
+
let check_result name = function
22
13
| D.Match | D.Both_failed -> ()
23
-
| D.Value_mismatch msg ->
24
-
Cr.fail (Printf.sprintf "%s: value mismatch: %s" name msg)
25
-
| D.Only_c_ok msg ->
26
-
Cr.fail (Printf.sprintf "%s: only C succeeded: %s" name msg)
14
+
| D.Value_mismatch msg -> Alcotest.failf "%s: value mismatch: %s" name msg
15
+
| D.Only_c_ok msg -> Alcotest.failf "%s: only C succeeded: %s" name msg
27
16
| D.Only_ocaml_ok msg ->
28
-
Cr.fail (Printf.sprintf "%s: only OCaml succeeded: %s" name msg)
17
+
Alcotest.failf "%s: only OCaml succeeded: %s" name msg
29
18
30
-
let () =
31
-
Cr.run "diff"
32
-
(List.concat_map
33
-
(fun (t : D.packed_test) ->
34
-
[
35
-
Cr.test_case (t.name ^ " read") [ Cr.bytes ] (fun buf ->
36
-
check t.name (t.test_read (truncate buf)));
37
-
Cr.test_case (t.name ^ " write") [ Cr.bytes ] (fun buf ->
38
-
check t.name (t.test_write (pad t.wire_size buf)));
39
-
Cr.test_case (t.name ^ " roundtrip") [ Cr.bytes ] (fun buf ->
40
-
check t.name (t.test_roundtrip (pad t.wire_size buf)));
41
-
])
42
-
All_schemas.all)
19
+
(* Roundtrip a simple struct through the OCaml codec *)
20
+
let test_roundtrip_struct () =
21
+
let s =
22
+
Wire.struct_ "Simple"
23
+
[ Wire.field "a" Wire.uint8; Wire.field "b" Wire.uint16 ]
24
+
in
25
+
let buf = "\x01\x02\x03" in
26
+
match D.roundtrip_struct s buf with
27
+
| Ok out -> Alcotest.(check string) "roundtrip" buf out
28
+
| Error e -> Alcotest.failf "roundtrip failed: %a" Wire.pp_parse_error e
29
+
30
+
(* Schema with no C implementation — Both_failed is acceptable *)
31
+
let test_schema_read_no_c () =
32
+
let wire_size = 3 in
33
+
let buf = pad wire_size "\xff\xff\xff" in
34
+
let s =
35
+
Wire.Codec.(
36
+
record "NoCTest" (fun a b -> (a, b))
37
+
|+ field "a" Wire.uint8 fst |+ field "b" Wire.uint16 snd |> seal)
38
+
in
39
+
let schema =
40
+
D.schema ~name:"NoCTest" ~codec:s
41
+
~c_read:(fun _ -> None)
42
+
~c_write:(fun _ -> None)
43
+
~equal:(fun (a1, b1) (a2, b2) -> a1 = a2 && b1 = b2)
44
+
in
45
+
check_result "no_c read" (D.read schema buf)
46
+
47
+
let suite =
48
+
( "diff",
49
+
[
50
+
Alcotest.test_case "roundtrip_struct" `Quick test_roundtrip_struct;
51
+
Alcotest.test_case "schema read (no C)" `Quick test_schema_read_no_c;
52
+
] )
+2
test/diff/test_diff.mli
+2
test/diff/test_diff.mli
+2
-1
test/dune
+2
-1
test/dune
+52
test/test_gen_3d.ml
+52
test/test_gen_3d.ml
···
1
+
(** Tests for Wire 3D code generation. *)
2
+
3
+
open Wire
4
+
5
+
let test_generate_bitfields () =
6
+
let bf =
7
+
struct_ "BF"
8
+
[
9
+
field "x" (bits ~width:6 bf_uint32);
10
+
field "y"
11
+
~constraint_:Expr.(ref "y" <= int 900)
12
+
(bits ~width:10 bf_uint32);
13
+
field "z"
14
+
~constraint_:Expr.(ref "y" + ref "z" <= int 60000)
15
+
(bits ~width:16 bf_uint32);
16
+
]
17
+
in
18
+
let m = module_ "Bitfields" [ typedef bf ] in
19
+
let output = to_3d m in
20
+
Alcotest.(check bool) "non-empty output" true (String.length output > 0)
21
+
22
+
let test_generate_enumerations () =
23
+
let m =
24
+
module_ "Enumerations"
25
+
[
26
+
enum_decl "Enum8"
27
+
[ ("Enum8_1", 0); ("Enum8_2", 1); ("Enum8_3", 2) ]
28
+
uint8;
29
+
]
30
+
in
31
+
let output = to_3d m in
32
+
Alcotest.(check bool) "non-empty output" true (String.length output > 0)
33
+
34
+
let test_to_3d_file () =
35
+
let s = struct_ "Simple" [ field "a" uint8 ] in
36
+
let m = module_ "Simple" [ typedef s ] in
37
+
let tmp = Filename.temp_file "wire_test" ".3d" in
38
+
to_3d_file tmp m;
39
+
let ic = open_in tmp in
40
+
let contents = really_input_string ic (in_channel_length ic) in
41
+
close_in ic;
42
+
Sys.remove tmp;
43
+
Alcotest.(check bool) "file non-empty" true (String.length contents > 0)
44
+
45
+
let suite =
46
+
( "gen_3d",
47
+
[
48
+
Alcotest.test_case "generate bitfields" `Quick test_generate_bitfields;
49
+
Alcotest.test_case "generate enumerations" `Quick
50
+
test_generate_enumerations;
51
+
Alcotest.test_case "to_3d_file" `Quick test_to_3d_file;
52
+
] )
+2
test/test_gen_3d.mli
+2
test/test_gen_3d.mli
+40
-44
test/test_wire.ml
+40
-44
test/test_wire.ml
···
99
99
let input = "\x42" in
100
100
match parse_string uint8 input with
101
101
| Ok v -> Alcotest.(check int) "uint8 value" 0x42 v
102
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
102
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
103
103
104
104
let test_parse_uint16_le () =
105
105
let input = "\x01\x02" in
106
106
match parse_string uint16 input with
107
107
| Ok v -> Alcotest.(check int) "uint16 le value" 0x0201 v
108
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
108
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
109
109
110
110
let test_parse_uint16_be () =
111
111
let input = "\x01\x02" in
112
112
match parse_string uint16be input with
113
113
| Ok v -> Alcotest.(check int) "uint16 be value" 0x0102 v
114
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
114
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
115
115
116
116
let test_parse_uint32_le () =
117
117
let input = "\x01\x02\x03\x04" in
118
118
match parse_string uint32 input with
119
119
| Ok v -> Alcotest.(check int) "uint32 le value" 0x04030201 v
120
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
120
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
121
121
122
122
let test_parse_uint32_be () =
123
123
let input = "\x01\x02\x03\x04" in
124
124
match parse_string uint32be input with
125
125
| Ok v -> Alcotest.(check int) "uint32 be value" 0x01020304 v
126
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
126
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
127
127
128
128
let test_parse_uint64_le () =
129
129
let input = "\x01\x02\x03\x04\x05\x06\x07\x08" in
130
130
match parse_string uint64 input with
131
131
| Ok v -> Alcotest.(check int64) "uint64 le value" 0x0807060504030201L v
132
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
132
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
133
133
134
134
let test_parse_array () =
135
135
let input = "\x01\x02\x03" in
136
136
let t = array ~len:(int 3) uint8 in
137
137
match parse_string t input with
138
138
| Ok v -> Alcotest.(check (list int)) "array values" [ 1; 2; 3 ] v
139
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
139
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
140
140
141
141
let test_parse_byte_array () =
142
142
let input = "hello" in
143
143
let t = byte_array ~size:(int 5) in
144
144
match parse_string t input with
145
145
| Ok v -> Alcotest.(check string) "byte_array value" "hello" v
146
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
146
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
147
147
148
148
let test_parse_enum_valid () =
149
149
let input = "\x01" in
150
150
let t = enum "Test" [ ("A", 0); ("B", 1); ("C", 2) ] uint8 in
151
151
match parse_string t input with
152
152
| Ok v -> Alcotest.(check int) "enum value" 1 v
153
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
153
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
154
154
155
155
let test_parse_enum_invalid () =
156
156
let input = "\xFF" in
···
159
159
| Ok _ -> Alcotest.fail "expected error for invalid enum"
160
160
| Error (Invalid_enum { value; _ }) ->
161
161
Alcotest.(check int) "invalid enum value" 255 value
162
-
| Error e ->
163
-
Alcotest.fail (Format.asprintf "wrong error: %a" pp_parse_error e)
162
+
| Error e -> Alcotest.failf "wrong error: %a" pp_parse_error e
164
163
165
164
let test_parse_all_bytes () =
166
165
let input = "hello world" in
167
166
match parse_string all_bytes input with
168
167
| Ok v -> Alcotest.(check string) "all_bytes value" "hello world" v
169
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
168
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
170
169
171
170
let test_parse_all_zeros_valid () =
172
171
let input = "\x00\x00\x00" in
173
172
match parse_string all_zeros input with
174
173
| Ok _ -> ()
175
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
174
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
176
175
177
176
let test_parse_all_zeros_invalid () =
178
177
let input = "\x00\x01\x00" in
···
180
179
| Ok _ -> Alcotest.fail "expected error for non-zero byte"
181
180
| Error (All_zeros_failed { offset }) ->
182
181
Alcotest.(check int) "non-zero offset" 1 offset
183
-
| Error e ->
184
-
Alcotest.fail (Format.asprintf "wrong error: %a" pp_parse_error e)
182
+
| Error e -> Alcotest.failf "wrong error: %a" pp_parse_error e
185
183
186
184
let test_parse_bitfield () =
187
185
let input = "\xFF\xFF\xFF\xFF" in
188
186
let t = bits ~width:6 bf_uint32 in
189
187
match parse_string t input with
190
188
| Ok v -> Alcotest.(check int) "bitfield value (6 bits)" 63 v
191
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
189
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
192
190
193
191
let test_parse_eof () =
194
192
let input = "\x01" in
···
197
195
| Error (Unexpected_eof { expected; got }) ->
198
196
Alcotest.(check int) "expected bytes" 2 expected;
199
197
Alcotest.(check int) "got bytes" 1 got
200
-
| Error e ->
201
-
Alcotest.fail (Format.asprintf "wrong error: %a" pp_parse_error e)
198
+
| Error e -> Alcotest.failf "wrong error: %a" pp_parse_error e
202
199
203
200
let test_parse_struct () =
204
201
let input = "\x01\x02\x03" in
···
208
205
let t = struct_typ s in
209
206
match parse_string t input with
210
207
| Ok () -> ()
211
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
208
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
212
209
213
210
let test_parse_struct_constraint () =
214
211
(* Test struct with constraint that should pass *)
···
220
217
let t = struct_typ s in
221
218
match parse_string t input with
222
219
| Ok () -> ()
223
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
220
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
224
221
225
222
let test_parse_struct_constraint_fail () =
226
223
(* Test struct with constraint that should fail *)
···
233
230
match parse_string t input with
234
231
| Ok _ -> Alcotest.fail "expected constraint failure"
235
232
| Error (Constraint_failed _) -> ()
236
-
| Error e ->
237
-
Alcotest.fail (Format.asprintf "wrong error: %a" pp_parse_error e)
233
+
| Error e -> Alcotest.failf "wrong error: %a" pp_parse_error e
238
234
239
235
(* Encoding tests *)
240
236
···
286
282
let encoded = encode_to_string uint8 original in
287
283
match parse_string uint8 encoded with
288
284
| Ok decoded -> Alcotest.(check int) "roundtrip uint8" original decoded
289
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
285
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
290
286
291
287
let test_roundtrip_uint16 () =
292
288
let original = 0x1234 in
293
289
let encoded = encode_to_string uint16 original in
294
290
match parse_string uint16 encoded with
295
291
| Ok decoded -> Alcotest.(check int) "roundtrip uint16" original decoded
296
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
292
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
297
293
298
294
let test_roundtrip_uint32 () =
299
295
let original = 0x12345678 in
300
296
let encoded = encode_to_string uint32 original in
301
297
match parse_string uint32 encoded with
302
298
| Ok decoded -> Alcotest.(check int) "roundtrip uint32" original decoded
303
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
299
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
304
300
305
301
let test_roundtrip_array () =
306
302
let original = [ 1; 2; 3; 4; 5 ] in
···
308
304
let encoded = encode_to_string t original in
309
305
match parse_string t encoded with
310
306
| Ok decoded -> Alcotest.(check (list int)) "roundtrip array" original decoded
311
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
307
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
312
308
313
309
let test_roundtrip_byte_array () =
314
310
let original = "hello" in
···
317
313
match parse_string t encoded with
318
314
| Ok decoded ->
319
315
Alcotest.(check string) "roundtrip byte_array" original decoded
320
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
316
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
321
317
322
318
(* Record codec tests *)
323
319
···
334
330
let test_record_encode () =
335
331
let v = { a = 0x42; b = 0x1234; c = 0x56789ABC } in
336
332
match encode_record_to_string simple_record_codec v with
337
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
333
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
338
334
| Ok encoded ->
339
335
(* uint8 + uint16_le + uint32_le *)
340
336
Alcotest.(check int) "length" 7 (String.length encoded);
···
350
346
Alcotest.(check int) "a" 0x42 v.a;
351
347
Alcotest.(check int) "b" 0x1234 v.b;
352
348
Alcotest.(check int) "c" 0x56789ABC v.c
353
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
349
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
354
350
355
351
let test_record_roundtrip () =
356
352
let original = { a = 0xAB; b = 0xCDEF; c = 0x12345678 } in
357
353
match encode_record_to_string simple_record_codec original with
358
-
| Error e -> Alcotest.fail (Format.asprintf "encode: %a" pp_parse_error e)
354
+
| Error e -> Alcotest.failf "encode: %a" pp_parse_error e
359
355
| Ok encoded -> (
360
356
match decode_record_from_string simple_record_codec encoded with
361
357
| Ok decoded ->
362
358
Alcotest.(check int) "a roundtrip" original.a decoded.a;
363
359
Alcotest.(check int) "b roundtrip" original.b decoded.b;
364
360
Alcotest.(check int) "c roundtrip" original.c decoded.c
365
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e))
361
+
| Error e -> Alcotest.failf "%a" pp_parse_error e)
366
362
367
363
let test_record_to_struct () =
368
364
let s = Codec.to_struct simple_record_codec in
···
388
384
let test_record_with_multi () =
389
385
let original = { x = 0x1234; y = 0x5678 } in
390
386
match encode_record_to_string multi_record_codec original with
391
-
| Error e -> Alcotest.fail (Format.asprintf "encode: %a" pp_parse_error e)
387
+
| Error e -> Alcotest.failf "encode: %a" pp_parse_error e
392
388
| Ok encoded -> (
393
389
Alcotest.(check int) "length" 4 (String.length encoded);
394
390
match decode_record_from_string multi_record_codec encoded with
395
391
| Ok decoded ->
396
392
Alcotest.(check int) "x" original.x decoded.x;
397
393
Alcotest.(check int) "y" original.y decoded.y
398
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e))
394
+
| Error e -> Alcotest.failf "%a" pp_parse_error e)
399
395
400
396
(* Record with byte_array field *)
401
397
type ba_record = { id : int; uuid : string; tag : int }
···
411
407
let test_record_byte_array_roundtrip () =
412
408
let original = { id = 0x12345678; uuid = "0123456789abcdef"; tag = 0xABCD } in
413
409
match encode_record_to_string ba_record_codec original with
414
-
| Error e -> Alcotest.fail (Format.asprintf "encode: %a" pp_parse_error e)
410
+
| Error e -> Alcotest.failf "encode: %a" pp_parse_error e
415
411
| Ok encoded -> (
416
412
Alcotest.(check int) "wire size" 22 (String.length encoded);
417
413
match decode_record_from_string ba_record_codec encoded with
···
419
415
Alcotest.(check int) "id" original.id decoded.id;
420
416
Alcotest.(check string) "uuid" original.uuid decoded.uuid;
421
417
Alcotest.(check int) "tag" original.tag decoded.tag
422
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e))
418
+
| Error e -> Alcotest.failf "%a" pp_parse_error e)
423
419
424
420
let test_record_byte_array_padding () =
425
421
(* Short string should be zero-padded *)
426
422
let original = { id = 1; uuid = "short"; tag = 2 } in
427
423
match encode_record_to_string ba_record_codec original with
428
-
| Error e -> Alcotest.fail (Format.asprintf "encode: %a" pp_parse_error e)
424
+
| Error e -> Alcotest.failf "encode: %a" pp_parse_error e
429
425
| Ok encoded -> (
430
426
Alcotest.(check int) "wire size" 22 (String.length encoded);
431
427
(* Verify zero padding: bytes 9..19 should be zero *)
432
428
for i = 9 to 19 do
433
429
Alcotest.(check int)
434
-
(Printf.sprintf "padding byte %d" i)
430
+
(Fmt.str "padding byte %d" i)
435
431
0
436
432
(Char.code encoded.[i])
437
433
done;
···
442
438
Alcotest.(check string)
443
439
"uuid prefix" "short"
444
440
(String.sub decoded.uuid 0 5)
445
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e))
441
+
| Error e -> Alcotest.failf "%a" pp_parse_error e)
446
442
447
443
(* Codec bitfield tests *)
448
444
···
489
485
let test_codec_bitfield_roundtrip () =
490
486
let original = { bf_a = 5; bf_b = 20; bf_c = 0x1234; bf_d = 0xAB } in
491
487
match encode_record_to_string bf32_codec original with
492
-
| Error e -> Alcotest.fail (Format.asprintf "encode: %a" pp_parse_error e)
488
+
| Error e -> Alcotest.failf "encode: %a" pp_parse_error e
493
489
| Ok encoded -> (
494
490
match decode_record_from_string bf32_codec encoded with
495
491
| Ok decoded ->
···
497
493
Alcotest.(check int) "b" original.bf_b decoded.bf_b;
498
494
Alcotest.(check int) "c" original.bf_c decoded.bf_c;
499
495
Alcotest.(check int) "d" original.bf_d decoded.bf_d
500
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e))
496
+
| Error e -> Alcotest.failf "%a" pp_parse_error e)
501
497
502
498
let test_codec_bitfield_byte_layout () =
503
499
(* a=5 (3b), b=20 (5b), c=0x1234 (16b), d=0xAB (8b)
···
505
501
= 0xB4 0x12 0x34 0xAB *)
506
502
let v = { bf_a = 5; bf_b = 20; bf_c = 0x1234; bf_d = 0xAB } in
507
503
match encode_record_to_string bf32_codec v with
508
-
| Error e -> Alcotest.fail (Format.asprintf "encode: %a" pp_parse_error e)
504
+
| Error e -> Alcotest.failf "encode: %a" pp_parse_error e
509
505
| Ok encoded ->
510
506
Alcotest.(check int) "length" 4 (String.length encoded);
511
507
Alcotest.(check int) "byte 0" 0xB4 (Char.code encoded.[0]);
···
522
518
Alcotest.(check int) "b" 20 v.bf_b;
523
519
Alcotest.(check int) "c" 0x1234 v.bf_c;
524
520
Alcotest.(check int) "d" 0xAB v.bf_d
525
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e)
521
+
| Error e -> Alcotest.failf "%a" pp_parse_error e
526
522
527
523
let test_codec_bitfield_multi_group () =
528
524
(* Two bf_uint16be groups: (3+2+11=16) + (14+2=16) = 32 bits = 4 bytes *)
···
530
526
{ bf_ver = 5; bf_flags = 2; bf_id = 0x7FF; bf_count = 0x3FFF; bf_len = 3 }
531
527
in
532
528
match encode_record_to_string bf16_codec v with
533
-
| Error e -> Alcotest.fail (Format.asprintf "encode: %a" pp_parse_error e)
529
+
| Error e -> Alcotest.failf "encode: %a" pp_parse_error e
534
530
| Ok encoded -> (
535
531
Alcotest.(check int) "length" 4 (String.length encoded);
536
532
(* First group: 101_10_11111111111 = 0xB7FF *)
···
547
543
Alcotest.(check int) "id" v.bf_id decoded.bf_id;
548
544
Alcotest.(check int) "count" v.bf_count decoded.bf_count;
549
545
Alcotest.(check int) "len" v.bf_len decoded.bf_len
550
-
| Error e -> Alcotest.fail (Format.asprintf "%a" pp_parse_error e))
546
+
| Error e -> Alcotest.failf "%a" pp_parse_error e)
551
547
552
548
let test_codec_bitfield_to_struct () =
553
549
let s = Codec.to_struct bf32_codec in