File: t_appendix_a.ml

package info (click to toggle)
ocaml-containers 3.15%2Bdfsg-1
  • links: PTS, VCS
  • area: main
  • in suites: sid, trixie
  • size: 2,412 kB
  • sloc: ml: 33,221; sh: 122; makefile: 32
file content (175 lines) | stat: -rw-r--r-- 5,557 bytes parent folder | download
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
let verbose = try Sys.getenv "VERBOSE" = "1" with _ -> false

module J = Yojson.Safe
module Fmt = CCFormat
module Cbor = Containers_cbor

type json = Yojson.Safe.t

module Test = struct
  type expect =
    | Diagnostic of string
    | Decoded of json

  type t = {
    hex: string;
    raw: string;
    expect: expect;
    roundtrip: bool;
  }
end

let list_assoc_opt x l = try Some (List.assoc x l) with _ -> None

let extract_tests (j : json) : Test.t list =
  let l = J.Util.to_list j in
  List.map
    (fun o ->
      let o = J.Util.to_assoc o in
      let hex = J.Util.to_string @@ List.assoc "hex" o in
      let raw = CCString.of_hex_exn @@ hex in
      let roundtrip = J.Util.to_bool @@ List.assoc "roundtrip" o in
      let expect =
        match list_assoc_opt "decoded" o, list_assoc_opt "diagnostic" o with
        | None, Some (`String s) -> Test.Diagnostic s
        | Some o, _ -> Test.Decoded o
        | _ -> failwith "cannot find expected result"
      in
      { Test.hex; raw; expect; roundtrip })
    l

(* a few tests we need to skip *)
let skip =
  [
    "c249010000000000000000", "(bigint)";
    "1BFFFFFFFFFFFFFFFF", "(requires int64, loss of precision)";
    "3bffffffffffffffff", "(requires int64, loss of precision)";
    "1bffffffffffffffff", "(requires int64 loss of precision)";
    "5f42010243030405ff", "(requires representation of indefinite length)";
  ]

type count = {
  mutable n_ok: int;
  mutable n_err: int;
  mutable n_skip: int;
}

let run_test (c : count) (t : Test.t) : unit =
  try
    match Cbor.decode_exn t.raw with
    | exception e ->
      c.n_err <- c.n_err + 1;
      Fmt.printf "error when decoding %S: %s@." t.hex (Printexc.to_string e)
    | cbor ->
      if verbose then Fmt.printf "  decoded into %a@." Cbor.pp_diagnostic cbor;

      (* do we skip the rest of the test? *)
      (match List.assoc_opt t.hex skip with
      | Some reason ->
        c.n_skip <- 1 + c.n_skip;
        if verbose then
          Fmt.printf "> @{<Yellow>SKIP@} %S (reason: %s)@." t.hex reason
      | None ->
        if verbose then Fmt.printf "> RUN test %S@." t.hex;

        (* check roundtrip, except on floats because we always use float64 *)
        if
          t.roundtrip
          &&
          match cbor with
          | `Float _ -> false
          | _ -> true
        then (
          let hex' = Cbor.encode cbor |> CCString.to_hex in
          if hex' <> t.hex then (
            Fmt.printf
              "  @[<v>@{<Red>mismatch@} on roundtrip:@ from %S@ to %S@]@." t.hex
              hex';
            c.n_err <- c.n_err + 1;
            raise Exit
          ) else if verbose then
            Fmt.printf "  roundtrip ok@."
        );

        (match t.expect with
        | Test.Diagnostic s ->
          let s' = Cbor.to_string_diagnostic cbor in
          (* adjust display *)
          let s' =
            match s' with
            | "inf" -> "Infinity"
            | "-inf" -> "-Infinity"
            | "nan" -> "NaN"
            | _ -> s'
          in
          if s = s' then (
            c.n_ok <- c.n_ok + 1;
            if verbose then Fmt.printf "  @{<Green>OK@}@."
          ) else (
            Fmt.printf "  @{<Red>ERR@}: expected diagnostic %S, got %S@." s s';
            c.n_err <- c.n_err + 1
          )
        | Test.Decoded j ->
          let rec compare_cj (cbor : Cbor.t) (j : json) =
            match cbor, j with
            | `Null, `Null -> true
            | `Float f1, `Float f2 -> Float.equal f1 f2
            | `Bool b1, `Bool b2 -> b1 = b2
            | `Map l, `Assoc l2 ->
              List.for_all
                (fun (k, v) ->
                  try compare_cj (List.assoc (`Text k) l) v
                  with Not_found -> false)
                l2
            | `Int i, `Int j -> i = Int64.of_int j
            | `Text s1, `String s2 -> s1 = s2
            | `Array l1, `List l2 ->
              List.length l1 = List.length l2 && List.for_all2 compare_cj l1 l2
            | `Int i, `Intlit s -> Int64.to_string i = s
            | _, `Intlit "-18446744073709551617" ->
              (* skip bigint test*)
              true
            | _ ->
              Fmt.printf "  TODO: compare %a with %a@." Cbor.pp_diagnostic cbor
                J.pp j;
              true
          in

          let ok = compare_cj cbor j in

          if ok then (
            c.n_ok <- 1 + c.n_ok;
            if verbose then Fmt.printf "  expect: @{<Green>OK@}@."
          ) else (
            c.n_err <- 1 + c.n_err;
            Fmt.printf "  expect: @{<Red>ERROR@} (got %a, expected %a)@."
              Cbor.pp_diagnostic cbor J.pp j
          )))
  with Exit -> ()

let run_tests (l : Test.t list) =
  let c = { n_err = 0; n_ok = 0; n_skip = 0 } in
  List.iter (run_test c) l;
  let has_err = c.n_err <> 0 in

  let total = c.n_err + c.n_ok + c.n_skip in
  if (verbose || has_err) && total <> List.length l then
    Fmt.printf "@{<Blue>warning@}: ran %d tests, for list of %d tests@." total
      (List.length l);

  if has_err then (
    Fmt.printf "@.@.#####@.@{<Red>FAIL@}: %d errors, %d ok, %d skip@." c.n_err
      c.n_ok c.n_skip;
    exit 1
  ) else
    Fmt.printf "@.@.#####@.@{<Green>OK@}: %d ok, %d skip@." c.n_ok c.n_skip

let () =
  let color = try Sys.getenv "COLOR" = "1" with _ -> false in
  if color then CCFormat.set_color_default true;
  let content = CCIO.File.read_exn Sys.argv.(1) in
  let j = Yojson.Safe.from_string content in
  let tests = extract_tests j in
  (*Format.printf "tests: %a@." (Fmt.Dump.list Test.pp) tests;*)
  run_tests tests;
  ()