ocaml-containers/tests/data/t_ringbuffer.ml

module Test = (val Containers_testlib.make ~__FILE__())
open Test
open CCRingBuffer;;

open Q.Gen
let g_char = map Char.chr (Char.code 'A' -- Char.code 'z')
let g_str = string_size ~gen:g_char (0--10)
let a_str = Q.set_gen g_str Q.string;;

t @@ fun () ->
  let b = Byte.of_array (Bytes.of_string "abc") in
  let b' = Byte.copy b in
  Byte.clear b;
  Byte.to_array b' = (Bytes.of_string "abc") && Byte.to_array b = Bytes.empty ;;

q a_str (fun s -> let s = Bytes.of_string s in
  let s_len = Bytes.length s in
  let b = Byte.create (max s_len 64) in
  Byte.blit_from b s 0 s_len;
  Byte.capacity b >= s_len);;

q a_str (fun s -> let s = Bytes.of_string s in
  let s_len = Bytes.length s in
  let b = Byte.create (max s_len 64) in
  Byte.blit_from b s 0 s_len;
  let b' = Byte.copy b in
  try Byte.iteri b
    ~f:(fun i c -> if Byte.get_front b' i <> c then raise Exit); true
  with Exit -> false);;

q a_str (fun s -> let s = Bytes.of_string s in
  let s_len = Bytes.length s in
  let b = Byte.create (max s_len 64) in
  Byte.blit_from b s 0 s_len;
  Byte.push_back b 'X';
  Byte.peek_back_exn b = 'X');;

q (Q.pair a_str a_str) (fun (s,s') ->
  let b = Byte.create (max (String.length s+String.length s') 64) in
  let s = Bytes.of_string s in let s' = Bytes.of_string s' in
  Byte.blit_from b s 0 (Bytes.length s);
  Byte.blit_from b s' 0 (Bytes.length s');
  Byte.length b = Bytes.length s + Bytes.length s');;

q (Q.pair a_str a_str) (fun (s,s') ->
  let s = Bytes.of_string s in let s' = Bytes.of_string s' in
  let b = Byte.create (max (Bytes.length s + Bytes.length s') 64) in
  Byte.blit_from b s 0 (Bytes.length s);
  Byte.blit_from b s' 0 (Bytes.length s');
  Byte.length b = Bytes.length s + Bytes.length s');;

q a_str (fun s -> let s = Bytes.of_string s in
  let b = Byte.create (max 64 (Bytes.length s)) in
  Byte.blit_from b s 0 (Bytes.length s);
  let to_buf = Bytes.create (Bytes.length s) in
  let len = Byte.blit_into b to_buf 0 (Bytes.length s) in
  to_buf = s && len = Bytes.length s);;

q a_str (fun s -> let s = Bytes.of_string s in
  let s_len = Bytes.length s in
  let b = Byte.create (max s_len 64) in
  Byte.blit_from b s 0 s_len;
  Byte.skip b s_len;
  Byte.is_empty b);;

q a_str (fun s -> let s = Bytes.of_string s in
  let s_len = Bytes.length s in
  let b = Byte.create (max s_len 64) in
  Byte.blit_from b s 0 s_len;
  try let front = Byte.take_front_exn b in
  front = Bytes.get s 0 with Byte.Empty -> s_len = 0);;

q a_str (fun s -> let s = Bytes.of_string s in
  let s_len = Bytes.length s in
  let b = Byte.create (max s_len 64) in
  Byte.blit_from b s 0 s_len;
  try let back = Byte.take_back_exn b in
      back = Bytes.get s (Bytes.length s - 1)
  with Byte.Empty -> s_len = 0);;

q a_str (fun s -> let s = Bytes.of_string s in
  let s_len = Bytes.length s in
  let b = Byte.create (max s_len 64) in
  Byte.blit_from b s 0 s_len;
  try let () = Byte.junk_front b in
  s_len - 1 = Byte.length b with Byte.Empty -> s_len = 0);;

q a_str (fun s -> let s = Bytes.of_string s in
  let s_len = Bytes.length s in
  let b = Byte.create (max s_len 64) in
  Byte.blit_from b s 0 s_len;
  try let () = Byte.junk_back b in
  s_len - 1 = Byte.length b with Byte.Empty -> s_len = 0);;

q (Q.pair a_str a_str) (fun (s,s') ->
  let s = Bytes.of_string s in let s' = Bytes.of_string s' in
  let b = Byte.create (max (Bytes.length s+Bytes.length s') 64) in
  Byte.blit_from b s 0 (Bytes.length s);
  Byte.blit_from b s' 0 (Bytes.length s');
  let h = Bytes.of_string "hello world" in
  Byte.blit_from b h 0 (Bytes.length h); (* big enough *)
  let l = Byte.length b in let l' = l/2 in Byte.skip b l';
  Byte.length b + l' = l);;

q a_str (fun s -> let s = Bytes.of_string s in
  let s_len = Bytes.length s in
  let b = Byte.create (max s_len 64) in
  Byte.blit_from b s 0 s_len;
  Byte.clear b;
  Byte.length b = 0);;

q a_str (fun s -> let s = Bytes.of_string s in
  let s_len = Bytes.length s in
  let b = Byte.create (max s_len 64) in
  Byte.blit_from b s 0 s_len;
  try Byte.iteri b ~f:(fun i c -> if Byte.get_front b i <> c then raise Exit);
    true with Exit -> false);;

q (Q.pair Q.small_int a_str) (fun (i, s) ->
  let s = Bytes.of_string (s ^ " ") in
  let s_len = Bytes.length s in
  let b = Byte.create (max s_len 64) in
  Byte.blit_from b s 0 s_len;
  let index = abs (i mod Byte.length b) in
  let front = Byte.get_front b index in
  front = Bytes.get s index);;

q (Q.pair Q.small_int a_str) (fun (i, s) ->
  let s = Bytes.of_string (s ^ " ") in
  let s_len = Bytes.length s in
  let b = Byte.create (max s_len 64) in
  Byte.blit_from b s 0 s_len;
  let index = abs (i mod Byte.length b) in
  let back = Byte.get_back b index in
  back = Bytes.get s (s_len - index - 1));;

q a_str (fun s -> let s = Bytes.of_string s in
  let s_len = Bytes.length s in
  let b = Byte.create (max s_len 64) in
  Byte.blit_from b s 0 s_len;
  let l = Byte.to_list b in
  let explode s = let rec exp i l =
   if i < 0 then l else exp (i - 1) (Bytes.get s i :: l) in
   exp (Bytes.length s - 1) [] in
  explode s = l);;

q a_str (fun s -> let s = Bytes.of_string s in
  let s_len = Bytes.length s in
  let b = Byte.create (max s_len 64) in
  Byte.blit_from b s 0 s_len;
  try let back = Byte.peek_front_exn b in
  back = Bytes.get s 0 with Byte.Empty -> s_len = 0);;

q a_str (fun s -> let s = Bytes.of_string s in
  let s_len = Bytes.length s in
  let b = Byte.create (max s_len 64) in
  Byte.blit_from b s 0 s_len;
  try let back = Byte.peek_back_exn b in
  back = Bytes.get s (s_len - 1) with Byte.Empty -> s_len = 0);;

q a_str (fun s -> let s = Bytes.of_string s in
    let b = Byte.of_array s in let s' = Byte.to_array b in
    s = s');;

module BI = CCRingBuffer.Make(struct type t = int let dummy=0 end);;

(* try to trigger an error on resize
   see issue #126 *)
t @@ fun () ->
  let b = BI.create 50 in
  let st = Random.State.make [| 0 |] in
  for _i = 1 to 100_000 do
    if Random.State.float st 1.0 < 0.5 then
      BI.push_back b 0
    else
      let _ = BI.take_front b in ()
  done;
  true;;

(* Test against reference implementation (lists) on a succession of
   operations.

   Remarks on semantics:

   JUNK_FRONT/JUNK_BACK: try to remove if not empty
   SKIP: if at least n elements, skip; else nop
*)

module BS = CCRingBuffer.Byte

type op =
| Push_back of char
| Take_front
| Take_back
| Peek_front
| Peek_back
| Junk_front
| Junk_back
| Skip of int
| Blit of string * int * int
| Z_if_full

let str_of_op = function
| Push_back c -> Printf.sprintf "push_back(%C)" c
| Take_front -> Printf.sprintf "take_front"
| Take_back -> Printf.sprintf "take_back"
| Peek_front -> Printf.sprintf "peek_front"
| Peek_back -> Printf.sprintf "peek_back"
| Junk_front -> Printf.sprintf "junk_front"
| Junk_back -> Printf.sprintf "junk_back"
| Skip n -> Printf.sprintf "skip(%d)" n
| Blit (s,i,len) -> Printf.sprintf "blit(%S,%d,%d)" s i len
| Z_if_full -> "zero_if_full"

let push_back c = Push_back c
let skip n = assert (n>=0); Skip n
let blit s i len =
if i<0 || len<0 || i+len > String.length s then (
  failwith ("wrong blit: " ^ str_of_op (Blit (s,i,len)));
);
Blit (s,i,len)

let shrink_op =
let open Q.Iter in
function
  | Push_back c -> Q.Shrink.char c >|= push_back
  | Take_front | Take_back | Junk_back | Junk_front
  | Z_if_full | Peek_front | Peek_back
  -> empty
  | Skip n -> Q.Shrink.int n >|= skip
  | Blit (s,i,len) ->
    let s_i =
      Q.Shrink.int i >>= fun i' ->
      assert (i' <= i && i' + len <= String.length s);
      if i' <= 0 then empty else return (blit s i' len)
    and s_len =
      Q.Shrink.int len >>= fun len'->
      assert (len' <= len && i + len' <= String.length s);
      if len' <= 0 then empty else return (blit s i len')
    and s_s =
      Q.Shrink.string s >>= fun s' ->
      if i+len > String.length s' then empty else return (blit s' i len)
    in
    append s_i (append s_len s_s)

let len_op size acc = function
| Push_back _ -> min size (acc + 1)
| Take_front | Take_back | Junk_front | Junk_back -> max (acc-1) 0
| Skip n -> if acc >= n then acc-n else acc
| Z_if_full | Peek_front | Peek_back -> acc
| Blit (_,_,len) -> min size (acc + len)

let apply_op b = function
| Push_back c -> BS.push_back b c; None
| Take_front -> BS.take_front b
| Take_back -> BS.take_back b
| Junk_front -> (try BS.junk_front b with BS.Empty -> ()); None
| Junk_back -> (try BS.junk_back b with BS.Empty -> ()); None
| Peek_front -> BS.peek_front b
| Peek_back -> BS.peek_back b
| Skip n -> if n <= BS.length b then BS.skip b n; None
| Blit (s,i,len) ->
  assert(i+len <= String.length s);
  BS.blit_from b (Bytes.unsafe_of_string s) i len; None
| Z_if_full -> if BS.is_full b then Some '0' else None

let gen_op =
let open Q.Gen in
let g_blit =
  string_size ~gen:g_char (5--20) >>= fun s ->
  (0 -- String.length s) >>= fun len ->
  assert (len >= 0 && len <= String.length s);
  (0--(String.length s-len)) >|= fun i ->
  blit s i len
in
frequency
  [ 3, return Take_back;
    3, return Take_front;
    1, return Junk_back;
    1, return Junk_front;
    1, return Peek_front;
    1, return Peek_back;
    2, g_blit;
    1, (0--5 >|= skip);
    2, map push_back g_char;
    1, return Z_if_full;
  ]

let arb_op =
Q.make
  ~shrink:shrink_op
  ~print:str_of_op
  gen_op

let arb_ops = Q.list_of_size Q.Gen.(0 -- 20) arb_op

module L_impl = struct
  type t = {
    size: int;
    mutable l: char list;
  }

  let create size = {size; l=[]}

  let normalize_ b =
    let n = List.length b.l in
    if n>b.size then b.l <- CCList.drop (n-b.size) b.l

  let push_back b c = b.l <- b.l @ [c]; normalize_ b
  let take_front b = match b.l with
    | [] -> None
    | c :: l -> b.l <- l; Some c
  let peek_front b = match b.l with [] -> None | x::_ -> Some x
  let take_back b =
    let n = List.length b.l in
    if n=0 then None
    else (
      let init, last = CCList.take_drop (n-1) b.l in
      let x = List.hd last in
      b.l <- init;
      Some x
    )
  let peek_back b = match b.l with [] -> None | l -> Some (List.hd (List.rev l))
  let junk_front b = ignore (take_front b)
  let junk_back b = ignore (take_back b)
  let skip b n =
    if n <= List.length b.l then (
      CCInt.range' 0 n (fun _ -> junk_front b)
    )

  let blit b s i len =
    for j=i to i+len-1 do push_back b (String.get s j) done

  let apply_op b = function
    | Push_back c -> push_back b c; None
    | Take_front -> take_front b
    | Take_back -> take_back b
    | Peek_front -> peek_front b
    | Peek_back -> peek_back b
    | Junk_back -> junk_back b; None
    | Junk_front -> junk_front b; None
    | Skip n -> skip b n; None
    | Blit (s,i,len) -> blit b s i len; None
    | Z_if_full -> if b.size = List.length b.l then Some '0' else None

  let to_list b = b.l
end;;

(* check that a lot of operations can be applied without failure,
   and that the result has correct length *)
q ~count:3_000
  arb_ops (fun ops ->
    let size = 64 in
    let b = BS.create size in
    List.iter (fun o-> ignore (apply_op b o)) ops;
    BS.length b = List.fold_left (len_op size) 0 ops);;

(* check identical behavior with list implem *)
q ~count:3_000
  arb_ops (fun ops ->
    let size = 64 in
    let b = BS.create size in
    let l = L_impl.create size in
    let l1 = CCList.filter_map (apply_op b) ops in
    let l2 = CCList.filter_map (L_impl.apply_op l) ops in
    l1=l2 && BS.to_list b = L_impl.to_list l);;

(* check that deleted elements can be GCed *)
module BO = CCRingBuffer.Make(struct type t = int option let dummy=None end)
let make_bo () =
  let b = BO.create 1000 in
  for i = 1 to BO.capacity b do
    BO.push_back b (Some i)
  done;
  b

let test_no_major_blocks clear =
  Gc.full_major ();
  let live_blocks_before = (Gc.stat ()).live_blocks in
  let b = make_bo () in
  clear b;
  Gc.full_major ();
  let live_blocks_after = (Gc.stat ()).live_blocks in
  assert (BO.length b = 0);
  let diff = live_blocks_after - live_blocks_before in
  diff < BO.capacity b / 2;;

t @@ fun () -> test_no_major_blocks (fun b -> for _ = 1 to BO.length b do BO.junk_front b; done);;
t @@ fun () -> test_no_major_blocks (fun b -> for _ = 1 to BO.length b do BO.junk_back b; done);;
t @@ fun () -> test_no_major_blocks (fun b -> for _ = 1 to BO.length b do ignore (BO.take_front b); done);;
t @@ fun () -> test_no_major_blocks (fun b -> for _ = 1 to BO.length b do ignore (BO.take_back b); done);;
t @@ fun () -> test_no_major_blocks (fun b -> BO.skip b (BO.length b));;
t @@ fun () -> test_no_major_blocks (fun b -> BO.clear b);;