open Bigarray
open Printf
open OUnit
open Bin_prot
open Common
open Utils
open ReadError
open Type_class
open Bin_prot.Std

module Bigstring = struct
  type t = buf

  let create = create_buf

  let of_string str =
    let len = String.length str in
    let buf = create len in
    blit_string_buf str buf ~len;
    buf
  ;;

  let length buf = Array1.dim buf
end

let expect_exc test_exc f =
  try
    ignore (f ());
    false
  with
  | exc -> test_exc exc
;;

let expect_bounds_error f =
  let test_exc = function
    | Invalid_argument "index out of bounds" -> true
    | _ -> false
  in
  expect_exc test_exc f
;;

let expect_buffer_short f =
  let exc = Buffer_short in
  expect_exc (( = ) exc) f
;;

let expect_read_error exp_re exp_pos f =
  let test_exc = function
    | Read_error (re, pos) -> exp_re = re && exp_pos = pos
    | _ -> false
  in
  expect_exc test_exc f
;;

let expect_no_error f =
  try
    ignore (f ());
    true
  with
  | _ -> false
;;

let check_write_bounds_checks name buf write arg =
  (name ^ ": negative bound") @? expect_bounds_error (fun () -> write buf ~pos:~-1 arg);
  (name ^ ": positive bound")
  @? expect_buffer_short (fun () -> write buf ~pos:(Bigstring.length buf) arg)
;;

let check_read_bounds_checks name buf read =
  (name ^ ": negative bound")
  @? expect_bounds_error (fun () -> read buf ~pos_ref:(ref ~-1));
  (name ^ ": positive bound")
  @? expect_buffer_short (fun () -> read buf ~pos_ref:(ref (Bigstring.length buf)))
;;

let check_write_result name buf pos write arg exp_len =
  let res_pos = write buf ~pos arg in
  sprintf
    "%s: returned wrong write position (%d, expected %d)"
    name
    res_pos
    (pos + exp_len)
  @? (res_pos = pos + exp_len)
;;

let check_read_result name buf pos read exp_ret exp_len =
  let pos_ref = ref pos in
  (name ^ ": returned wrong result") @? (read buf ~pos_ref = exp_ret);
  sprintf
    "%s: returned wrong read position (%d, expected %d)"
    name
    !pos_ref
    (pos + exp_len)
  @? (!pos_ref - pos = exp_len)
;;

let check_all_args tp_name read write buf args =
  let write_name = "write_" ^ tp_name ^ " " in
  let read_name = "read_" ^ tp_name ^ " " in
  let buf_len = Bigstring.length buf in
  let act (arg, str_arg, arg_len) =
    let write_name_arg = write_name ^ str_arg in
    let read_name_arg = read_name ^ str_arg in
    for pos = 0 to 8 do
      check_write_bounds_checks write_name buf write arg;
      check_read_bounds_checks read_name buf read;
      check_write_result write_name_arg buf pos write arg arg_len;
      check_read_result read_name_arg buf pos read arg arg_len
    done;
    (write_name_arg ^ ": write failed near bound")
    @? expect_no_error (fun () -> write buf ~pos:(buf_len - arg_len) arg);
    (read_name_arg ^ ": read failed near bound")
    @? expect_no_error (fun () ->
      if read buf ~pos_ref:(ref (buf_len - arg_len)) <> arg
      then failwith (read_name_arg ^ ": read near bound returned wrong result"));
    let small_buf = Array1.sub buf 0 (buf_len - 1) in
    (write_name_arg ^ ": write exceeds bound")
    @? expect_buffer_short (fun () -> write small_buf ~pos:(buf_len - arg_len) arg);
    (read_name_arg ^ ": read exceeds bound")
    @? expect_buffer_short (fun () -> read small_buf ~pos_ref:(ref (buf_len - arg_len)))
  in
  List.iter act args
;;

let mk_buf n =
  let bstr = Bigstring.create n in
  for i = 0 to n - 1 do
    bstr.{i} <- '\255'
  done;
  bstr
;;

let check_all extra_buf_size tp_name read write args =
  let buf_len = extra_buf_size + 8 in
  let buf = mk_buf buf_len in
  match args with
  | [] -> assert false
  | (arg, _, _) :: _ ->
    let write_name = "write_" ^ tp_name in
    check_write_bounds_checks write_name buf write arg;
    let read_name = "read_" ^ tp_name in
    check_read_bounds_checks read_name buf read;
    check_all_args tp_name read write buf args
;;

let random_string n = String.init n (fun _ -> Char.chr (Random.int 256))
let mk_int_test ~n ~len = n, Printf.sprintf "%x" n, len
let mk_nat0_test ~n ~len = Nat0.of_int n, Printf.sprintf "%x" n, len
let mk_float_test n = n, Printf.sprintf "%g" n, 8
let mk_int32_test ~n ~len = n, Printf.sprintf "%lx" n, len
let mk_int64_test ~n ~len = n, Printf.sprintf "%Lx" n, len
let mk_nativeint_test ~n ~len = n, Printf.sprintf "%nx" n, len

let mk_gen_float_vec tp n =
  let vec = Array1.create tp fortran_layout n in
  for i = 1 to n do
    vec.{i} <- float i
  done;
  vec
;;

let mk_float32_vec = mk_gen_float_vec float32
let mk_float64_vec = mk_gen_float_vec float64

let mk_bigstring n =
  let bstr = Array1.create char c_layout n in
  for i = 0 to n - 1 do
    bstr.{i} <- Char.chr (Random.int 256)
  done;
  bstr
;;

let mk_gen_float_mat tp m n =
  let mat = Array2.create tp fortran_layout m n in
  let fn = float m in
  for c = 1 to n do
    let ofs = float (c - 1) *. fn in
    for r = 1 to m do
      mat.{r, c} <- ofs +. float r
    done
  done;
  mat
;;

let mk_float32_mat = mk_gen_float_mat float32
let mk_float64_mat = mk_gen_float_mat float64

let test =
  "Bin_prot"
  >::: [ ("unit"
          >:: fun () ->
            check_all 1 "unit" Read.bin_read_unit Write.bin_write_unit [ (), "()", 1 ])
       ; ("bool"
          >:: fun () ->
            check_all
              1
              "bool"
              Read.bin_read_bool
              Write.bin_write_bool
              [ true, "true", 1; false, "false", 1 ])
       ; ("string"
          >:: fun () ->
            check_all
              66000
              "string"
              Read.bin_read_string
              Write.bin_write_string
              [ "", "\"\"", 1
              ; random_string 1, "random 1", 1 + 1
              ; random_string 10, "random 10", 10 + 1
              ; random_string 127, "random 127", 127 + 1
              ; random_string 128, "long 128", 128 + 3
              ; random_string 65535, "long 65535", 65535 + 3
              ; random_string 65536, "long 65536", 65536 + 5
              ];
            if Sys.word_size = 32
            then (
              let bad_buf = Bigstring.of_string "\253\252\255\255\000" in
              "String_too_long"
              @? expect_read_error String_too_long 0 (fun () ->
                Read.bin_read_string bad_buf ~pos_ref:(ref 0));
              let bad_buf = Bigstring.of_string "\253\251\255\255\000" in
              "StringMaximimum"
              @? expect_buffer_short (fun () ->
                Read.bin_read_string bad_buf ~pos_ref:(ref 0)))
            else (
              let bad_buf = Bigstring.of_string "\252\248\255\255\255\255\255\255\001" in
              "String_too_long"
              @? expect_read_error String_too_long 0 (fun () ->
                Read.bin_read_string bad_buf ~pos_ref:(ref 0));
              let bad_buf = Bigstring.of_string "\252\247\255\255\255\255\255\255\001" in
              "StringMaximimum"
              @? expect_buffer_short (fun () ->
                Read.bin_read_string bad_buf ~pos_ref:(ref 0))))
       ; ("char"
          >:: fun () ->
            check_all
              1
              "char"
              Read.bin_read_char
              Write.bin_write_char
              [ 'x', "x", 1; 'y', "y", 1 ])
       ; ("int"
          >:: fun () ->
            let small_int_tests =
              [ mk_int_test ~n:~-0x01 ~len:2
              ; mk_int_test ~n:0x00 ~len:1
              ; mk_int_test ~n:0x01 ~len:1
              ; mk_int_test ~n:0x7e ~len:1
              ; mk_int_test ~n:0x7f ~len:1
              ; mk_int_test ~n:0x80 ~len:3
              ; mk_int_test ~n:0x81 ~len:3
              ; mk_int_test ~n:0x7ffe ~len:3
              ; mk_int_test ~n:0x7fff ~len:3
              ; mk_int_test ~n:0x8000 ~len:5
              ; mk_int_test ~n:0x8001 ~len:5
              ; mk_int_test ~n:0x3ffffffe ~len:5
              ; mk_int_test ~n:0x3fffffff ~len:5
              ; mk_int_test ~n:~-0x7f ~len:2
              ; mk_int_test ~n:~-0x80 ~len:2
              ; mk_int_test ~n:~-0x81 ~len:3
              ; mk_int_test ~n:~-0x82 ~len:3
              ; mk_int_test ~n:~-0x7fff ~len:3
              ; mk_int_test ~n:~-0x8000 ~len:3
              ; mk_int_test ~n:~-0x8001 ~len:5
              ; mk_int_test ~n:~-0x8002 ~len:5
              ; mk_int_test ~n:~-0x40000001 ~len:5
              ; mk_int_test ~n:~-0x40000000 ~len:5
              ]
            in
            let all_int_tests =
              if Sys.word_size = 32
              then small_int_tests
              else
                mk_int_test ~n:(int_of_string "0x7ffffffe") ~len:5
                :: mk_int_test ~n:(int_of_string "0x7fffffff") ~len:5
                :: mk_int_test ~n:(int_of_string "0x80000000") ~len:9
                :: mk_int_test ~n:(int_of_string "0x80000001") ~len:9
                :: mk_int_test ~n:max_int ~len:9
                :: mk_int_test ~n:(int_of_string "-0x000000007fffffff") ~len:5
                :: mk_int_test ~n:(int_of_string "-0x0000000080000000") ~len:5
                :: mk_int_test ~n:(int_of_string "-0x0000000080000001") ~len:9
                :: mk_int_test ~n:(int_of_string "-0x0000000080000002") ~len:9
                :: mk_int_test ~n:min_int ~len:9
                :: small_int_tests
            in
            check_all 9 "int" Read.bin_read_int Write.bin_write_int all_int_tests;
            let bad_buf = Bigstring.of_string "\132" in
            "Int_code"
            @? expect_read_error Int_code 0 (fun () ->
              Read.bin_read_int bad_buf ~pos_ref:(ref 0));
            if Sys.word_size = 32
            then (
              let bad_buf = Bigstring.of_string "\253\255\255\255\064" in
              "Int_overflow (positive)"
              @? expect_read_error Int_overflow 0 (fun () ->
                Read.bin_read_int bad_buf ~pos_ref:(ref 0));
              let bad_buf = Bigstring.of_string "\253\255\255\255\191" in
              "Int_overflow (negative)"
              @? expect_read_error Int_overflow 0 (fun () ->
                Read.bin_read_int bad_buf ~pos_ref:(ref 0)))
            else (
              let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\255\064" in
              "Int_overflow (positive)"
              @? expect_read_error Int_overflow 0 (fun () ->
                Read.bin_read_int bad_buf ~pos_ref:(ref 0));
              let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\255\191" in
              "Int_overflow (negative)"
              @? expect_read_error Int_overflow 0 (fun () ->
                Read.bin_read_int bad_buf ~pos_ref:(ref 0))))
       ; ("nat0"
          >:: fun () ->
            let small_int_tests =
              [ mk_nat0_test ~n:0x00 ~len:1
              ; mk_nat0_test ~n:0x01 ~len:1
              ; mk_nat0_test ~n:0x7e ~len:1
              ; mk_nat0_test ~n:0x7f ~len:1
              ; mk_nat0_test ~n:0x80 ~len:3
              ; mk_nat0_test ~n:0x81 ~len:3
              ; mk_nat0_test ~n:0x7fff ~len:3
              ; mk_nat0_test ~n:0x8000 ~len:3
              ; mk_nat0_test ~n:0xffff ~len:3
              ; mk_nat0_test ~n:0x10000 ~len:5
              ; mk_nat0_test ~n:0x10001 ~len:5
              ; mk_nat0_test ~n:0x3ffffffe ~len:5
              ; mk_nat0_test ~n:0x3fffffff ~len:5
              ]
            in
            let all_int_tests =
              if Sys.word_size = 32
              then small_int_tests
              else
                mk_nat0_test ~n:(int_of_string "0x7fffffff") ~len:5
                :: mk_nat0_test ~n:(int_of_string "0x80000000") ~len:5
                :: mk_nat0_test ~n:(int_of_string "0xffffffff") ~len:5
                :: mk_nat0_test ~n:(int_of_string "0x100000000") ~len:9
                :: mk_nat0_test ~n:(int_of_string "0x100000001") ~len:9
                :: mk_nat0_test ~n:max_int ~len:9
                :: small_int_tests
            in
            check_all 9 "nat0" Read.bin_read_nat0 Write.bin_write_nat0 all_int_tests;
            let bad_buf = Bigstring.of_string "\128" in
            "Nat0_code"
            @? expect_read_error Nat0_code 0 (fun () ->
              Read.bin_read_nat0 bad_buf ~pos_ref:(ref 0));
            if Sys.word_size = 32
            then (
              let bad_buf = Bigstring.of_string "\253\255\255\255\064" in
              "Nat0_overflow"
              @? expect_read_error Nat0_overflow 0 (fun () ->
                Read.bin_read_nat0 bad_buf ~pos_ref:(ref 0)))
            else (
              let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\255\064" in
              "Nat0_overflow"
              @? expect_read_error Nat0_overflow 0 (fun () ->
                Read.bin_read_nat0 bad_buf ~pos_ref:(ref 0))))
       ; ("float"
          >:: fun () ->
            let float_tests =
              [ mk_float_test 0.
              ; mk_float_test (-0.)
              ; mk_float_test (-1.)
              ; mk_float_test 1.
              ; mk_float_test infinity
              ; mk_float_test (-.infinity)
              ; mk_float_test 1e-310
              ; (* subnormal *)
                mk_float_test (-1e-310)
              ; (* subnormal *)
                mk_float_test 3.141595
              ]
            in
            check_all 8 "float" Read.bin_read_float Write.bin_write_float float_tests)
       ; ("int32"
          >:: fun () ->
            let int32_tests =
              [ mk_int32_test ~n:(-0x01l) ~len:2
              ; mk_int32_test ~n:0x00l ~len:1
              ; mk_int32_test ~n:0x01l ~len:1
              ; mk_int32_test ~n:0x7el ~len:1
              ; mk_int32_test ~n:0x7fl ~len:1
              ; mk_int32_test ~n:0x80l ~len:3
              ; mk_int32_test ~n:0x81l ~len:3
              ; mk_int32_test ~n:0x7ffel ~len:3
              ; mk_int32_test ~n:0x7fffl ~len:3
              ; mk_int32_test ~n:0x8000l ~len:5
              ; mk_int32_test ~n:0x8001l ~len:5
              ; mk_int32_test ~n:0x7ffffffel ~len:5
              ; mk_int32_test ~n:0x7fffffffl ~len:5
              ; mk_int32_test ~n:(-0x7fl) ~len:2
              ; mk_int32_test ~n:(-0x80l) ~len:2
              ; mk_int32_test ~n:(-0x81l) ~len:3
              ; mk_int32_test ~n:(-0x82l) ~len:3
              ; mk_int32_test ~n:(-0x7fffl) ~len:3
              ; mk_int32_test ~n:(-0x8000l) ~len:3
              ; mk_int32_test ~n:(-0x8001l) ~len:5
              ; mk_int32_test ~n:(-0x8002l) ~len:5
              ; mk_int32_test ~n:(-0x80000001l) ~len:5
              ; mk_int32_test ~n:(-0x80000000l) ~len:5
              ]
            in
            check_all 5 "int32" Read.bin_read_int32 Write.bin_write_int32 int32_tests;
            let bad_buf = Bigstring.of_string "\132" in
            "Int32_code"
            @? expect_read_error Int32_code 0 (fun () ->
              Read.bin_read_int32 bad_buf ~pos_ref:(ref 0)))
       ; ("int64"
          >:: fun () ->
            let int64_tests =
              [ mk_int64_test ~n:(-0x01L) ~len:2
              ; mk_int64_test ~n:0x00L ~len:1
              ; mk_int64_test ~n:0x01L ~len:1
              ; mk_int64_test ~n:0x7eL ~len:1
              ; mk_int64_test ~n:0x7fL ~len:1
              ; mk_int64_test ~n:0x80L ~len:3
              ; mk_int64_test ~n:0x81L ~len:3
              ; mk_int64_test ~n:0x7ffeL ~len:3
              ; mk_int64_test ~n:0x7fffL ~len:3
              ; mk_int64_test ~n:0x8000L ~len:5
              ; mk_int64_test ~n:0x8001L ~len:5
              ; mk_int64_test ~n:0x7ffffffeL ~len:5
              ; mk_int64_test ~n:0x7fffffffL ~len:5
              ; mk_int64_test ~n:0x80000000L ~len:9
              ; mk_int64_test ~n:0x80000001L ~len:9
              ; mk_int64_test ~n:0x7ffffffffffffffeL ~len:9
              ; mk_int64_test ~n:0x7fffffffffffffffL ~len:9
              ; mk_int64_test ~n:(-0x7fL) ~len:2
              ; mk_int64_test ~n:(-0x80L) ~len:2
              ; mk_int64_test ~n:(-0x81L) ~len:3
              ; mk_int64_test ~n:(-0x82L) ~len:3
              ; mk_int64_test ~n:(-0x7fffL) ~len:3
              ; mk_int64_test ~n:(-0x8000L) ~len:3
              ; mk_int64_test ~n:(-0x8001L) ~len:5
              ; mk_int64_test ~n:(-0x8002L) ~len:5
              ; mk_int64_test ~n:(-0x7fffffffL) ~len:5
              ; mk_int64_test ~n:(-0x80000000L) ~len:5
              ; mk_int64_test ~n:(-0x80000001L) ~len:9
              ; mk_int64_test ~n:(-0x80000002L) ~len:9
              ; mk_int64_test ~n:(-0x8000000000000001L) ~len:9
              ; mk_int64_test ~n:(-0x8000000000000000L) ~len:9
              ]
            in
            check_all 9 "int64" Read.bin_read_int64 Write.bin_write_int64 int64_tests;
            let bad_buf = Bigstring.of_string "\132" in
            "Int64_code"
            @? expect_read_error Int64_code 0 (fun () ->
              Read.bin_read_int64 bad_buf ~pos_ref:(ref 0)))
       ; ("nativeint"
          >:: fun () ->
            let small_nativeint_tests =
              [ mk_nativeint_test ~n:(-0x01n) ~len:2
              ; mk_nativeint_test ~n:0x00n ~len:1
              ; mk_nativeint_test ~n:0x01n ~len:1
              ; mk_nativeint_test ~n:0x7en ~len:1
              ; mk_nativeint_test ~n:0x7fn ~len:1
              ; mk_nativeint_test ~n:0x80n ~len:3
              ; mk_nativeint_test ~n:0x81n ~len:3
              ; mk_nativeint_test ~n:0x7ffen ~len:3
              ; mk_nativeint_test ~n:0x7fffn ~len:3
              ; mk_nativeint_test ~n:0x8000n ~len:5
              ; mk_nativeint_test ~n:0x8001n ~len:5
              ; mk_nativeint_test ~n:0x7ffffffen ~len:5
              ; mk_nativeint_test ~n:0x7fffffffn ~len:5
              ; mk_nativeint_test ~n:(-0x7fn) ~len:2
              ; mk_nativeint_test ~n:(-0x80n) ~len:2
              ; mk_nativeint_test ~n:(-0x81n) ~len:3
              ; mk_nativeint_test ~n:(-0x82n) ~len:3
              ; mk_nativeint_test ~n:(-0x7fffn) ~len:3
              ; mk_nativeint_test ~n:(-0x8000n) ~len:3
              ; mk_nativeint_test ~n:(-0x8001n) ~len:5
              ; mk_nativeint_test ~n:(-0x8002n) ~len:5
              ; mk_nativeint_test ~n:(-0x7fffffffn) ~len:5
              ; mk_nativeint_test ~n:(-0x80000000n) ~len:5
              ]
            in
            let nativeint_tests =
              if Sys.word_size = 32
              then small_nativeint_tests
              else
                mk_nativeint_test ~n:0x80000000n ~len:9
                :: mk_nativeint_test ~n:0x80000001n ~len:9
                :: mk_nativeint_test ~n:(-0x80000001n) ~len:9
                :: mk_nativeint_test ~n:(-0x80000002n) ~len:9
                :: mk_nativeint_test ~n:(Nativeint.of_string "0x7ffffffffffffffe") ~len:9
                :: mk_nativeint_test ~n:(Nativeint.of_string "0x7fffffffffffffff") ~len:9
                :: mk_nativeint_test ~n:(Nativeint.of_string "-0x8000000000000001") ~len:9
                :: mk_nativeint_test ~n:(Nativeint.of_string "-0x8000000000000000") ~len:9
                :: small_nativeint_tests
            in
            let size = if Sys.word_size = 32 then 5 else 9 in
            check_all
              size
              "nativeint"
              Read.bin_read_nativeint
              Write.bin_write_nativeint
              nativeint_tests;
            let bad_buf = Bigstring.of_string "\251" in
            "Nativeint_code"
            @? expect_read_error Nativeint_code 0 (fun () ->
              Read.bin_read_nativeint bad_buf ~pos_ref:(ref 0));
            if Sys.word_size = 32
            then (
              let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\255\255" in
              "Nativeint_code (overflow)"
              @? expect_read_error Nativeint_code 0 (fun () ->
                Read.bin_read_nativeint bad_buf ~pos_ref:(ref 0))))
       ; ("ref"
          >:: fun () ->
            check_all
              1
              "ref"
              (Read.bin_read_ref Read.bin_read_int)
              (Write.bin_write_ref Write.bin_write_int)
              [ ref 42, "ref 42", 1 ])
       ; ("option"
          >:: fun () ->
            check_all
              2
              "option"
              (Read.bin_read_option Read.bin_read_int)
              (Write.bin_write_option Write.bin_write_int)
              [ Some 42, "Some 42", 2; None, "None", 1 ])
       ; ("pair"
          >:: fun () ->
            check_all
              9
              "pair"
              (Read.bin_read_pair Read.bin_read_float Read.bin_read_int)
              (Write.bin_write_pair Write.bin_write_float Write.bin_write_int)
              [ (3.141, 42), "(3.141, 42)", 9 ])
       ; ("triple"
          >:: fun () ->
            check_all
              14
              "triple"
              (Read.bin_read_triple
                 Read.bin_read_float
                 Read.bin_read_int
                 Read.bin_read_string)
              (Write.bin_write_triple
                 Write.bin_write_float
                 Write.bin_write_int
                 Write.bin_write_string)
              [ (3.141, 42, "test"), "(3.141, 42, \"test\")", 14 ])
       ; ("list"
          >:: fun () ->
            check_all
              12
              "list"
              (Read.bin_read_list Read.bin_read_int)
              (Write.bin_write_list Write.bin_write_int)
              [ [ 42; -1; 200; 33000 ], "[42; -1; 200; 33000]", 12; [], "[]", 1 ])
       ; ("array"
          >:: fun () ->
            let bin_read_int_array = Read.bin_read_array Read.bin_read_int in
            check_all
              12
              "array"
              bin_read_int_array
              (Write.bin_write_array Write.bin_write_int)
              [ [| 42; -1; 200; 33000 |], "[|42; -1; 200; 33000|]", 12; [||], "[||]", 1 ];
            if Sys.word_size = 32
            then (
              let bad_buf = Bigstring.of_string "\253\000\000\064\000" in
              "Array_too_long"
              @? expect_read_error Array_too_long 0 (fun () ->
                bin_read_int_array bad_buf ~pos_ref:(ref 0));
              let bad_buf = Bigstring.of_string "\253\255\255\063\000" in
              "ArrayMaximimum"
              @? expect_buffer_short (fun () -> bin_read_int_array bad_buf ~pos_ref:(ref 0)))
            else (
              let bad_buf = Bigstring.of_string "\252\000\000\000\000\000\000\064\000" in
              "Array_too_long"
              @? expect_read_error Array_too_long 0 (fun () ->
                bin_read_int_array bad_buf ~pos_ref:(ref 0));
              let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\063\000" in
              "ArrayMaximimum"
              @? expect_buffer_short (fun () -> bin_read_int_array bad_buf ~pos_ref:(ref 0)))
         )
       ; ("float_array"
          >:: fun () ->
            ((check_all
                33
                "float_array"
                Read.bin_read_float_array
                Write.bin_write_float_array
                [ [| 42.; -1.; 200.; 33000. |], "[|42.; -1.; 200.; 33000.|]", 33
                ; [||], "[||]", 1
                ];
              if Sys.word_size = 32
              then (
                let bad_buf = Bigstring.of_string "\253\000\000\032\000" in
                "Array_too_long (float)"
                @? expect_read_error Array_too_long 0 (fun () ->
                  Read.bin_read_float_array bad_buf ~pos_ref:(ref 0));
                let bad_buf = Bigstring.of_string "\253\255\255\031\000" in
                "ArrayMaximimum (float)"
                @? expect_buffer_short (fun () ->
                  Read.bin_read_float_array bad_buf ~pos_ref:(ref 0)))
              else (
                let bad_buf = Bigstring.of_string "\252\000\000\000\000\000\000\064\000" in
                "Array_too_long (float)"
                @? expect_read_error Array_too_long 0 (fun () ->
                  Read.bin_read_float_array bad_buf ~pos_ref:(ref 0));
                let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\063\000" in
                "ArrayMaximimum (float)"
                @? expect_buffer_short (fun () ->
                  Read.bin_read_float_array bad_buf ~pos_ref:(ref 0));
                (* Test that the binary forms of [float array] and [float_array] are the same *)
                let arrays =
                  let rec loop acc len =
                    if len < 0
                    then acc
                    else (
                      let a = Array.init len (fun i -> float_of_int (i + len)) in
                      let txt = Printf.sprintf "float array, len = %d" len in
                      let buf = (len * 8) + Size.bin_size_nat0 (Nat0.unsafe_of_int len) in
                      loop ((a, txt, buf) :: acc) (len - 1))
                  in
                  loop [] 255
                in
                let len = (255 * 8) + Size.bin_size_nat0 (Nat0.unsafe_of_int 255) in
                check_all
                  len
                  "float array -> float_array"
                  Read.bin_read_float_array
                  (Write.bin_write_array Write.bin_write_float)
                  arrays;
                check_all
                  len
                  "float_array -> float array"
                  (Read.bin_read_array Read.bin_read_float)
                  Write.bin_write_float_array
                  arrays;
                (* Check that the canonical closures used in the short circuit test of float
                   arrays are indeed allocated closures as opposed to [compare] for example
                   which is a primitive.  Even if it looks like a tautology, it is not. (for
                   example, [compare == compare] is false. *)
                assert (bin_write_float == bin_write_float);
                assert (bin_read_float == bin_read_float);
                assert (bin_size_float == bin_size_float))) [@ocaml.alert "-deprecated"]))
       ; ("hashtbl"
          >:: fun () ->
            let bindings = List.rev [ 42, 3.; 17, 2.; 42, 4. ] in
            let htbl = Hashtbl.create (List.length bindings) in
            List.iter (fun (k, v) -> Hashtbl.add htbl k v) bindings;
            check_all
              28
              "hashtbl"
              (Read.bin_read_hashtbl Read.bin_read_int Read.bin_read_float)
              (Write.bin_write_hashtbl Write.bin_write_int Write.bin_write_float)
              [ htbl, "[(42, 3.); (17, 2.); (42, 4.)]", 28; Hashtbl.create 0, "[]", 1 ])
       ; ("float32_vec"
          >:: fun () ->
            let n = 128 in
            let header = 3 in
            let size = header + (n * 4) in
            let vec = mk_float32_vec n in
            check_all
              size
              "float32_vec"
              Read.bin_read_float32_vec
              Write.bin_write_float32_vec
              [ vec, "[| ... |]", size; mk_float32_vec 0, "[||]", 1 ])
       ; ("float64_vec"
          >:: fun () ->
            let n = 127 in
            let header = 1 in
            let size = header + (n * 8) in
            let vec = mk_float64_vec n in
            check_all
              size
              "float64_vec"
              Read.bin_read_float64_vec
              Write.bin_write_float64_vec
              [ vec, "[| ... |]", size; mk_float64_vec 0, "[||]", 1 ])
       ; ("vec"
          >:: fun () ->
            let n = 128 in
            let header = 3 in
            let size = header + (n * 8) in
            let vec = mk_float64_vec n in
            check_all
              size
              "vec"
              Read.bin_read_vec
              Write.bin_write_vec
              [ vec, "[| ... |]", size; mk_float64_vec 0, "[||]", 1 ])
       ; ("float32_mat"
          >:: fun () ->
            let m = 128 in
            let n = 127 in
            let header = 3 + 1 in
            let size = header + (m * n * 4) in
            let mat = mk_float32_mat m n in
            check_all
              size
              "float32_mat"
              Read.bin_read_float32_mat
              Write.bin_write_float32_mat
              [ mat, "[| ... |]", size; mk_float32_mat 0 0, "[||]", 2 ])
       ; ("float64_mat"
          >:: fun () ->
            let m = 10 in
            let n = 12 in
            let header = 1 + 1 in
            let size = header + (m * n * 8) in
            let mat = mk_float64_mat m n in
            check_all
              size
              "float64_mat"
              Read.bin_read_float64_mat
              Write.bin_write_float64_mat
              [ mat, "[| ... |]", size; mk_float64_mat 0 0, "[||]", 2 ])
       ; ("mat"
          >:: fun () ->
            let m = 128 in
            let n = 128 in
            let header = 3 + 3 in
            let size = header + (m * n * 8) in
            let mat = mk_float64_mat m n in
            check_all
              size
              "mat"
              Read.bin_read_mat
              Write.bin_write_mat
              [ mat, "[| ... |]", size; mk_float64_mat 0 0, "[||]", 2 ])
       ; ("bigstring"
          >:: fun () ->
            let n = 128 in
            let header = 3 in
            let size = header + n in
            let bstr = mk_bigstring n in
            check_all
              size
              "bigstring"
              Read.bin_read_bigstring
              Write.bin_write_bigstring
              [ bstr, "[| ... |]", size; mk_bigstring 0, "[||]", 1 ])
       ; ("bigstring (big)"
          >:: fun () ->
            (* [n] is a 16bits integer that will be serialized differently depending on
               whether it is considered as an integer or an unsigned integer. *)
            let n = 40_000 in
            let header = 3 in
            let size = header + n in
            let bstr = mk_bigstring n in
            check_all
              size
              "bigstring"
              Read.bin_read_bigstring
              Write.bin_write_bigstring
              [ bstr, "[| ... |]", size; mk_bigstring 0, "[||]", 1 ])
       ; ("variant_tag"
          >:: fun () ->
            check_all
              4
              "variant_tag"
              Read.bin_read_variant_int
              Write.bin_write_variant_int
              [ (Obj.magic `Foo : int), "`Foo", 4; (Obj.magic `Bar : int), "`Bar", 4 ];
            let bad_buf = Bigstring.of_string "\000\000\000\000" in
            "Variant_tag"
            @? expect_read_error Variant_tag 0 (fun () ->
              Read.bin_read_variant_int bad_buf ~pos_ref:(ref 0)))
       ; ("int64_bits"
          >:: fun () ->
            check_all
              8
              "int64_bits"
              Read.bin_read_int64_bits
              Write.bin_write_int64_bits
              [ Int64.min_int, "min_int", 8
              ; Int64.add Int64.min_int Int64.one, "min_int + 1", 8
              ; Int64.minus_one, "-1", 8
              ; Int64.zero, "0", 8
              ; Int64.one, "1", 8
              ; Int64.sub Int64.max_int Int64.one, "max_int - 1", 8
              ; Int64.max_int, "max_int", 8
              ])
       ; ("int_64bit"
          >:: fun () ->
            check_all
              8
              "int_64bit"
              Read.bin_read_int_64bit
              Write.bin_write_int_64bit
              [ min_int, "min_int", 8
              ; min_int + 1, "min_int + 1", 8
              ; -1, "-1", 8
              ; 0, "0", 8
              ; 1, "1", 8
              ; max_int - 1, "max_int - 1", 8
              ; max_int, "max_int", 8
              ];
            let bad_buf_max =
              bin_dump bin_int64_bits.writer (Int64.succ (Int64.of_int max_int))
            in
            "Int_overflow (positive)"
            @? expect_read_error Int_overflow 0 (fun () ->
              Read.bin_read_int_64bit bad_buf_max ~pos_ref:(ref 0));
            let bad_buf_min =
              bin_dump bin_int64_bits.writer (Int64.pred (Int64.of_int min_int))
            in
            "Int_overflow (negative)"
            @? expect_read_error Int_overflow 0 (fun () ->
              Read.bin_read_int_64bit bad_buf_min ~pos_ref:(ref 0)))
       ; ("network16_int"
          >:: fun () ->
            check_all
              2
              "network16_int"
              Read.bin_read_network16_int
              Write.bin_write_network16_int
              [ (* No negative numbers - ambiguous on 64bit platforms *)
                0, "0", 2
              ; 1, "1", 2
              ])
       ; ("network32_int"
          >:: fun () ->
            check_all
              4
              "network32_int"
              Read.bin_read_network32_int
              Write.bin_write_network32_int
              [ (* No negative numbers - ambiguous on 64bit platforms *)
                0, "0", 4
              ; 1, "1", 4
              ])
       ; ("network32_int32"
          >:: fun () ->
            check_all
              4
              "network32_int32"
              Read.bin_read_network32_int32
              Write.bin_write_network32_int32
              [ -1l, "-1", 4; 0l, "0", 4; 1l, "1", 4 ])
       ; ("network64_int"
          >:: fun () ->
            check_all
              8
              "network64_int"
              Read.bin_read_network64_int
              Write.bin_write_network64_int
              [ -1, "-1", 8; 0, "0", 8; 1, "1", 8 ])
       ; ("network64_int64"
          >:: fun () ->
            check_all
              8
              "network64_int64"
              Read.bin_read_network64_int64
              Write.bin_write_network64_int64
              [ -1L, "-1", 8; 0L, "0", 8; 1L, "1", 8 ])
       ]
;;

module Common = struct
  type tuple = float * string * int64 [@@deriving bin_io]

  type 'a record =
    { a : int
    ; b : 'a
    ; c : 'a option
    }
  [@@deriving bin_io]

  type 'a singleton_record = { y : 'a } [@@deriving bin_io]

  type 'a inline_record =
    | IR of
        { mutable ir_a : int
        ; ir_b : 'a
        ; ir_c : 'a option
        }
    | Other of int
  [@@deriving bin_io]

  type 'a sum =
    | Foo
    | Bar of int
    | Bla of 'a * string
  [@@deriving bin_io]

  type 'a variant =
    [ `Foo
    | `Bar of int
    | `Bla of 'a * string
    ]
  [@@deriving bin_io]

  type 'a poly_app =
    (tuple * int singleton_record * 'a record * 'a inline_record) variant sum list
  [@@deriving bin_io]

  type 'a rec_t1 = RecFoo1 of 'a rec_t2

  and 'a rec_t2 =
    | RecFoo2 of 'a poly_app * 'a rec_t1
    | RecNone
  [@@deriving bin_io]

  type 'a poly_id = 'a rec_t1 [@@deriving bin_io]
  type el = float poly_id [@@deriving bin_io]
  type els = el array [@@deriving bin_io]

  module Wildcard : sig
    type _ transparent = int [@@deriving bin_io]
    type _ opaque [@@deriving bin_io]

    val opaque_examples : int opaque list
  end = struct
    type _ transparent = int [@@deriving bin_io]
    type 'a opaque = 'a option [@@deriving bin_io]

    let opaque_examples = [ None; Some 0; Some 1 ]
  end

  let test =
    "Bin_prot_common"
    >::: [ ("Utils.bin_dump"
            >:: fun () ->
              let el =
                let record = { a = 17; b = 2.78; c = None } in
                let inline_record = IR { ir_a = 18; ir_b = 43210.; ir_c = None } in
                let arg = (3.1, "foo", 42L), { y = 4321 }, record, inline_record in
                let variant = `Bla (arg, "fdsa") in
                let sum = Bla (variant, "asdf") in
                let poly_app = [ sum ] in
                RecFoo1 (RecFoo2 (poly_app, RecFoo1 RecNone))
              in
              let els = Array.make 10 el in
              let buf = bin_dump ~header:true bin_els.writer els in
              let pos_ref = ref 0 in
              let els_len = Read.bin_read_int_64bit buf ~pos_ref in
              "pos_ref for length incorrect" @? (!pos_ref = 8);
              "els_len disagrees with bin_size" @? (els_len = bin_size_els els);
              let new_els = bin_read_els buf ~pos_ref in
              "new_els and els not equal" @? (els = new_els))
         ]
  ;;
end

module Inline = struct
  let compatible xs derived_tc inline_writer inline_reader inline_tc =
    ListLabels.map xs ~f:(fun x ->
      ""
      >:: fun () ->
        "incorrect size from inline writer"
        @? (derived_tc.writer.size x = inline_writer.size x);
        "incorrect size from inline type class"
        @? (derived_tc.writer.size x = inline_tc.writer.size x);
        let buf = bin_dump derived_tc.writer x in
        "incorrect bin dump from inline writer" @? (buf = bin_dump inline_writer x);
        "incorrect bin dump from inline type class" @? (buf = bin_dump inline_tc.writer x);
        let val_and_len reader =
          let pos_ref = ref 0 in
          let x = reader.read buf ~pos_ref in
          x, !pos_ref
        in
        let _, len = val_and_len derived_tc.reader in
        let x', len' = val_and_len inline_reader in
        "incorrect value from inline reader" @? (x = x');
        "incorrect length from inline reader" @? (len = len');
        let x', len' = val_and_len inline_tc.reader in
        "incorrect value from inline type class" @? (x = x');
        "incorrect length from inline type class" @? (len = len'))
  ;;

  type variant_extension =
    [ float Common.variant
    | `Baz of int * float
    ]
  [@@deriving bin_io]

  let test =
    "Bin_prot.Inline"
    >::: [ "simple tuple"
           >::: compatible
                  [ 50.5, "hello", 1234L ]
                  Common.bin_tuple
                  [%bin_writer: Common.tuple]
                  [%bin_reader: Common.tuple]
                  [%bin_type_class: Common.tuple]
         ; "redefine tuple"
           >::: compatible
                  [ 50.5, "hello", 1234L ]
                  Common.bin_tuple
                  [%bin_writer: float * string * int64]
                  [%bin_reader: float * string * int64]
                  [%bin_type_class: float * string * int64]
         ; "simple variant"
           >::: compatible
                  [ `Foo; `Bar 8; `Bla (33.3, "world") ]
                  (Common.bin_variant bin_float)
                  [%bin_writer: float Common.variant]
                  [%bin_reader: float Common.variant]
                  [%bin_type_class: float Common.variant]
         ; "redefine variant"
           >::: compatible
                  [ `Foo; `Bar 8; `Bla (33.3, "world") ]
                  (Common.bin_variant bin_float)
                  [%bin_writer: [ `Foo | `Bar of int | `Bla of float * string ]]
                  [%bin_reader: [ `Foo | `Bar of int | `Bla of float * string ]]
                  [%bin_type_class: [ `Foo | `Bar of int | `Bla of float * string ]]
         ; "variant_extension"
           >::: compatible
                  [ `Foo; `Bar 8; `Bla (33.3, "world"); `Baz (17, 17.71) ]
                  bin_variant_extension
                  [%bin_writer: [ float Common.variant | `Baz of int * float ]]
                  [%bin_reader: [ float Common.variant | `Baz of int * float ]]
                  [%bin_type_class: [ float Common.variant | `Baz of int * float ]]
         ; "sub variant"
           >::: compatible
                  [ { Common.y = `Foo }; { y = `Bar 42 }; { y = `Bla (42, "world") } ]
                  (Common.bin_singleton_record (Common.bin_variant bin_int))
                  [%bin_writer:
                    [ `Foo | `Bar of int | `Bla of int * string ] Common.singleton_record]
                  [%bin_reader:
                    [ `Foo | `Bar of int | `Bla of int * string ] Common.singleton_record]
                  [%bin_type_class:
                    [ `Foo | `Bar of int | `Bla of int * string ] Common.singleton_record]
         ; "transparent wildcard"
           >::: compatible
                  [ 1; 2; 3 ]
                  (Common.Wildcard.bin_transparent bin_string)
                  [%bin_writer: string Common.Wildcard.transparent]
                  [%bin_reader: string Common.Wildcard.transparent]
                  [%bin_type_class: string Common.Wildcard.transparent]
         ; "opaque wildcard"
           >::: compatible
                  Common.Wildcard.opaque_examples
                  (Common.Wildcard.bin_opaque bin_int)
                  [%bin_writer: int Common.Wildcard.opaque]
                  [%bin_reader: int Common.Wildcard.opaque]
                  [%bin_type_class: int Common.Wildcard.opaque]
         ]
  ;;
end
