unikernel/duniverse/base/test/helpers/dune

@@ -0,0 +1,5 @@
+(library
+ (name base_test_helpers)
+ (libraries base)
+ (preprocess
+  (pps ppx_jane)))

unikernel/duniverse/base/test/helpers/test_container.ml

@@ -0,0 +1,210 @@
+open! Base
+open! Container
+
+module Test_generic (Elt : sig
+  type 'a t
+
+  val of_int : int -> int t
+  val to_int : int t -> int
+end) (Container : sig
+  type 'a t [@@deriving sexp]
+
+  include Generic with type ('a, _, _) t := 'a t with type 'a elt := 'a Elt.t
+
+  val mem : 'a t -> 'a Elt.t -> equal:('a Elt.t -> 'a Elt.t -> bool) -> bool
+  val of_list : 'a Elt.t list -> [ `Ok of 'a t | `Skip_test ]
+end) : sig
+  type 'a t [@@deriving sexp]
+
+  include Generic with type ('a, _, _) t := 'a t
+
+  val mem : 'a t -> 'a Elt.t -> equal:('a Elt.t -> 'a Elt.t -> bool) -> bool
+end
+with type 'a t := 'a Container.t
+with type 'a elt := 'a Elt.t =
+(* This signature constraint reminds us to add unit tests when functions are added to
+   [Generic]. *)
+struct
+  open Container
+
+  let find = find
+  let find_map = find_map
+  let fold = fold
+  let is_empty = is_empty
+  let iter = iter
+  let length = length
+  let mem = mem
+  let sexp_of_t = sexp_of_t
+  let t_of_sexp = t_of_sexp
+  let to_array = to_array
+  let to_list = to_list
+  let fold_result = fold_result
+  let fold_until = fold_until
+
+  let%test_unit _ =
+    let ( = ) = Poly.equal in
+    let compare = Poly.compare in
+    List.iter [ 0; 1; 2; 3; 4; 8; 128 ] ~f:(fun n ->
+      let list = List.init n ~f:Elt.of_int in
+      match Container.of_list list with
+      | `Skip_test -> ()
+      | `Ok c ->
+        let sort l = List.sort l ~compare in
+        let sorts_are_equal l1 l2 = sort l1 = sort l2 in
+        assert (n = Container.length c);
+        assert (n = 0 = Container.is_empty c);
+        assert (sorts_are_equal list (Container.fold c ~init:[] ~f:(fun ac e -> e :: ac)));
+        assert (sorts_are_equal list (Container.to_list c));
+        assert (sorts_are_equal list (Array.to_list (Container.to_array c)));
+        assert (n > 0 = Option.is_some (Container.find c ~f:(fun e -> Elt.to_int e = 0)));
+        assert (
+          n > 0 = Option.is_some (Container.find c ~f:(fun e -> Elt.to_int e = n - 1)));
+        assert (Option.is_none (Container.find c ~f:(fun e -> Elt.to_int e = n)));
+        assert (n > 0 = Container.mem c (Elt.of_int 0) ~equal:( = ));
+        if n > 0 then assert (Container.mem c (Elt.of_int (n - 1)) ~equal:( = ));
+        assert (not (Container.mem c (Elt.of_int n) ~equal:( = )));
+        assert (
+          n
+          > 0
+          = Option.is_some
+              (Container.find_map c ~f:(fun e ->
+                 if Elt.to_int e = 0 then Some () else None)));
+        assert (
+          n
+          > 0
+          = Option.is_some
+              (Container.find_map c ~f:(fun e ->
+                 if Elt.to_int e = n - 1 then Some () else None)));
+        assert (
+          Option.is_none
+            (Container.find_map c ~f:(fun e -> if Elt.to_int e = n then Some () else None)));
+        let r = ref 0 in
+        Container.iter c ~f:(fun e -> r := !r + Elt.to_int e);
+        assert (!r = List.fold list ~init:0 ~f:(fun n e -> n + Elt.to_int e));
+        assert (!r = sum (module Int) c ~f:Elt.to_int);
+        let c2 = [%of_sexp: int Container.t] ([%sexp_of: int Container.t] c) in
+        assert (sorts_are_equal list (Container.to_list c2));
+        let compare_elt a b = Int.compare (Elt.to_int a) (Elt.to_int b) in
+        if n = 0
+        then (
+          assert (!r = 0);
+          assert (min_elt ~compare:compare_elt c = None);
+          assert (max_elt ~compare:compare_elt c = None))
+        else (
+          assert (!r = n * (n - 1) / 2);
+          assert (Option.map ~f:Elt.to_int (min_elt ~compare:compare_elt c) = Some 0);
+          assert (
+            Option.map ~f:Elt.to_int (max_elt ~compare:compare_elt c) = Some (Int.pred n)));
+        let mid = Container.length c / 2 in
+        (match
+           Container.fold_result c ~init:0 ~f:(fun count _elt ->
+             if count = mid then Error count else Ok (count + 1))
+         with
+         | Ok 0 -> assert (Container.length c = 0)
+         | Ok _ -> failwith "Expected fold to stop early"
+         | Error x -> assert (mid = x)))
+  ;;
+
+  let min_elt = min_elt
+  let max_elt = max_elt
+  let count = count
+  let sum = sum
+  let exists = exists
+  let for_all = for_all
+
+  let%test_unit _ =
+    List.iter
+      [ []
+      ; [ true ]
+      ; [ false ]
+      ; [ false; false ]
+      ; [ true; false ]
+      ; [ false; true ]
+      ; [ true; true ]
+      ]
+      ~f:(fun bools ->
+        let count_should_be =
+          List.fold bools ~init:0 ~f:(fun n b -> if b then n + 1 else n)
+        in
+        let forall_should_be = List.fold bools ~init:true ~f:(fun ac b -> b && ac) in
+        let exists_should_be = List.fold bools ~init:false ~f:(fun ac b -> b || ac) in
+        match
+          Container.of_list (List.map bools ~f:(fun b -> Elt.of_int (if b then 1 else 0)))
+        with
+        | `Skip_test -> ()
+        | `Ok container ->
+          let is_one e = Elt.to_int e = 1 in
+          let ( = ) = Poly.equal in
+          assert (forall_should_be = Container.for_all container ~f:is_one);
+          assert (exists_should_be = Container.exists container ~f:is_one);
+          assert (count_should_be = Container.count container ~f:is_one))
+  ;;
+end
+
+module Test_S1_allow_skipping_tests (Container : sig
+  type 'a t [@@deriving sexp]
+
+  include Container.S1 with type 'a t := 'a t
+
+  val of_list : 'a list -> [ `Ok of 'a t | `Skip_test ]
+end) =
+struct
+  include
+    Test_generic
+      (struct
+        type 'a t = 'a
+
+        let of_int = Fn.id
+        let to_int = Fn.id
+      end)
+      (Container)
+end
+
+module Test_S1 (Container : sig
+  type 'a t [@@deriving sexp]
+
+  include Container.S1 with type 'a t := 'a t
+
+  val of_list : 'a list -> 'a t
+end) =
+Test_S1_allow_skipping_tests (struct
+  include Container
+
+  let of_list l = `Ok (of_list l)
+end)
+
+module Test_S0 (Container : sig
+  module Elt : sig
+    type t [@@deriving sexp]
+
+    val of_int : int -> t
+    val to_int : t -> int
+  end
+
+  type t [@@deriving sexp]
+
+  include Container.S0 with type t := t and type elt := Elt.t
+
+  val of_list : Elt.t list -> t
+end) =
+struct
+  include
+    Test_generic
+      (struct
+        include Container.Elt
+
+        type 'a t = Container.Elt.t
+      end)
+      (struct
+        include Container
+
+        type 'a t = Container.t [@@deriving sexp]
+
+        let of_list l = `Ok (of_list l)
+        let mem t x ~equal:_ = Container.mem t x
+      end)
+
+  (* [mem] in the second functor argument above ignores its [~equal], so this [~equal]
+     should never be called. *)
+  let mem t x = mem t x ~equal:(fun _ _ -> assert false)
+end

unikernel/duniverse/base/test/helpers/test_container.mli

@@ -0,0 +1,57 @@
+open! Base
+open! Container
+
+module Test_S1_allow_skipping_tests (Container : sig
+  type 'a t [@@deriving sexp]
+
+  include Container.S1 with type 'a t := 'a t
+
+  val of_list : 'a list -> [ `Ok of 'a t | `Skip_test ]
+end) : sig
+  type 'a t [@@deriving sexp]
+
+  include Generic with type ('a, _, _) t := 'a t
+
+  val mem : 'a t -> 'a -> equal:('a -> 'a -> bool) -> bool
+end
+with type 'a t := 'a Container.t
+with type 'a elt := 'a
+
+module Test_S1 (Container : sig
+  type 'a t [@@deriving sexp]
+
+  include Container.S1 with type 'a t := 'a t
+
+  val of_list : 'a list -> 'a t
+end) : sig
+  type 'a t [@@deriving sexp]
+
+  include Generic with type ('a, _, _) t := 'a t
+
+  val mem : 'a t -> 'a -> equal:('a -> 'a -> bool) -> bool
+end
+with type 'a t := 'a Container.t
+with type 'a elt := 'a
+
+module Test_S0 (Container : sig
+  module Elt : sig
+    type t [@@deriving sexp]
+
+    val of_int : int -> t
+    val to_int : t -> int
+  end
+
+  type t [@@deriving sexp]
+
+  include Container.S0 with type t := t and type elt := Elt.t
+
+  val of_list : Elt.t list -> t
+end) : sig
+  type 'a t [@@deriving sexp]
+
+  include Generic with type ('a, _, _) t := 'a t
+
+  val mem : 'a t -> 'a elt -> bool
+end
+with type 'a t := Container.t
+with type 'a elt := Container.Elt.t

unikernel/duniverse/base/test/helpers/test_stack.ml

@@ -0,0 +1,296 @@
+open! Base
+open! Stack
+
+module Debug (Stack : S) : S with type 'a t = 'a Stack.t = struct
+  open Stack
+
+  type nonrec 'a t = 'a t
+
+  let invariant = invariant
+  let t_sexp_grammar = t_sexp_grammar
+
+  let check_and_return t =
+    invariant ignore t;
+    t
+  ;;
+
+  let debug t f =
+    let result = Result.try_with f in
+    invariant ignore t;
+    Result.ok_exn result
+  ;;
+
+  (* The return-type annotations are to prevent an error where we don't supply all the
+     arguments to the function, and thus wouldn't be checking the invariant after fully
+     applying the function. *)
+  let clear t : unit = debug t (fun () -> clear t)
+  let copy t : _ t = check_and_return (debug t (fun () -> copy t))
+  let count t ~f : int = debug t (fun () -> count t ~f) [@nontail]
+  let sum m t ~f = debug t (fun () -> sum m t ~f) [@nontail]
+  let create () : _ t = check_and_return (create ())
+  let exists t ~f : bool = debug t (fun () -> exists t ~f) [@nontail]
+  let find t ~f : _ option = debug t (fun () -> find t ~f) [@nontail]
+  let find_map t ~f : _ option = debug t (fun () -> find_map t ~f) [@nontail]
+  let fold (type a) t ~init ~f : a = debug t (fun () -> fold t ~init ~f) [@nontail]
+  let for_all t ~f : bool = debug t (fun () -> for_all t ~f) [@nontail]
+  let is_empty t : bool = debug t (fun () -> is_empty t)
+  let iter t ~f : unit = debug t (fun () -> iter t ~f) [@nontail]
+  let length t : int = debug t (fun () -> length t)
+  let mem t a ~equal : bool = debug t (fun () -> mem t a ~equal) [@nontail]
+  let of_list l : _ t = check_and_return (of_list l)
+  let pop t : _ option = debug t (fun () -> pop t)
+  let pop_exn (type a) t : a = debug t (fun () -> pop_exn t)
+  let push t a : unit = debug t (fun () -> push t a)
+  let sexp_of_t sexp_of_a t : Sexp.t = debug t (fun () -> [%sexp_of: a t] t)
+  let singleton x : _ t = check_and_return (singleton x)
+  let t_of_sexp a_of_sexp sexp : _ t = check_and_return ([%of_sexp: a t] sexp)
+  let to_array t : _ array = debug t (fun () -> to_array t)
+  let to_list t : _ list = debug t (fun () -> to_list t)
+  let top t : _ option = debug t (fun () -> top t)
+  let top_exn (type a) t : a = debug t (fun () -> top_exn t)
+  let until_empty t f : unit = debug t (fun () -> until_empty t f) [@nontail]
+  let min_elt t ~compare : _ option = debug t (fun () -> min_elt t ~compare) [@nontail]
+  let max_elt t ~compare : _ option = debug t (fun () -> max_elt t ~compare) [@nontail]
+  let fold_result t ~init ~f = debug t (fun () -> fold_result t ~init ~f) [@nontail]
+
+  let fold_until t ~init ~f ~finish =
+    debug t (fun () -> fold_until t ~init ~f ~finish) [@nontail]
+  ;;
+
+  let filter_map t ~f = debug t (fun () -> filter_map t ~f) [@nontail]
+  let filter t ~f = debug t (fun () -> filter t ~f) [@nontail]
+  let filter_inplace t ~f = debug t (fun () -> filter_inplace t ~f) [@nontail]
+end
+
+module Test (Stack : S) : S with type 'a t = 'a Stack.t =
+(* This signature is here to remind us to add a unit test whenever we add something to
+   the stack interface. *)
+struct
+  open Stack
+
+  type nonrec 'a t = 'a t
+
+  include Test_container.Test_S1 (Stack)
+
+  let t_sexp_grammar = t_sexp_grammar
+  let invariant = invariant
+  let create = create
+  let is_empty = is_empty
+  let top_exn = top_exn
+  let pop_exn = pop_exn
+  let pop = pop
+  let top = top
+  let singleton = singleton
+
+  let%test_unit _ =
+    let empty = create () in
+    invariant ignore empty;
+    invariant (fun b -> assert b) (of_list [ true ]);
+    assert (is_empty empty);
+    let t = create () in
+    push t 0;
+    assert (not (is_empty t));
+    assert (Exn.does_raise (fun () -> top_exn empty));
+    let t = create () in
+    push t 0;
+    [%test_result: int] (top_exn t) ~expect:0;
+    assert (Exn.does_raise (fun () -> pop_exn empty));
+    let t = create () in
+    push t 0;
+    [%test_result: int] (pop_exn t) ~expect:0;
+    assert (Option.is_none (pop empty));
+    assert (Option.is_some (pop (of_list [ 0 ])));
+    assert (Option.is_none (top empty));
+    assert (Option.is_some (top (of_list [ 0 ])));
+    assert (Option.is_some (top (singleton 0)));
+    assert (Option.is_some (pop (singleton 0)));
+    assert (
+      let t = singleton 0 in
+      ignore (pop_exn t : int);
+      Option.is_none (top t))
+  ;;
+
+  let min_elt = min_elt
+  let max_elt = max_elt
+
+  let%test_unit _ =
+    let empty = create () in
+    [%test_result: _ option] (min_elt ~compare:Int.compare empty) ~expect:None;
+    [%test_result: _ option] (max_elt ~compare:Int.compare empty) ~expect:None;
+    [%test_result: int] (sum (module Int) ~f:Fn.id empty) ~expect:0
+  ;;
+
+  let push = push
+  let copy = copy
+  let until_empty = until_empty
+
+  let%test_unit _ =
+    let t =
+      let t = create () in
+      push t 0;
+      push t 1;
+      push t 2;
+      t
+    in
+    [%test_result: bool] (is_empty t) ~expect:false;
+    [%test_result: int] (length t) ~expect:3;
+    [%test_result: int option] (top t) ~expect:(Some 2);
+    [%test_result: int] (top_exn t) ~expect:2;
+    [%test_result: int option] (min_elt ~compare:Int.compare t) ~expect:(Some 0);
+    [%test_result: int option] (max_elt ~compare:Int.compare t) ~expect:(Some 2);
+    [%test_result: int] (sum (module Int) ~f:Fn.id t) ~expect:3;
+    let t' = copy t in
+    [%test_result: int] (pop_exn t') ~expect:2;
+    [%test_result: int] (pop_exn t') ~expect:1;
+    [%test_result: int] (pop_exn t') ~expect:0;
+    [%test_result: int] (length t') ~expect:0;
+    [%test_result: bool] (is_empty t') ~expect:true;
+    let t' = copy t in
+    [%test_result: int option] (pop t') ~expect:(Some 2);
+    [%test_result: int option] (pop t') ~expect:(Some 1);
+    [%test_result: int option] (pop t') ~expect:(Some 0);
+    [%test_result: int] (length t') ~expect:0;
+    [%test_result: bool] (is_empty t') ~expect:true;
+    (* test that t was not modified by pops applied to copies *)
+    [%test_result: int] (length t) ~expect:3;
+    [%test_result: int] (top_exn t) ~expect:2;
+    [%test_result: int list] (to_list t) ~expect:[ 2; 1; 0 ];
+    [%test_result: int array] (to_array t) ~expect:[| 2; 1; 0 |];
+    [%test_result: int] (length t) ~expect:3;
+    [%test_result: int] (top_exn t) ~expect:2;
+    let t' = copy t in
+    let n = ref 0 in
+    until_empty t' (fun x -> n := !n + x);
+    [%test_result: int] !n ~expect:3;
+    [%test_result: bool] (is_empty t') ~expect:true;
+    [%test_result: int] (length t') ~expect:0
+  ;;
+
+  let%test_unit _ =
+    let t = create () in
+    [%test_result: bool] (is_empty t) ~expect:true;
+    [%test_result: int] (length t) ~expect:0;
+    [%test_result: _ list] (to_list t) ~expect:[];
+    [%test_result: _ option] (pop t) ~expect:None;
+    push t 13;
+    [%test_result: bool] (is_empty t) ~expect:false;
+    [%test_result: int] (length t) ~expect:1;
+    [%test_result: int option] (min_elt ~compare:Int.compare t) ~expect:(Some 13);
+    [%test_result: int option] (max_elt ~compare:Int.compare t) ~expect:(Some 13);
+    [%test_result: int] (sum (module Int) ~f:Fn.id t) ~expect:13;
+    [%test_result: int] (pop_exn t) ~expect:13;
+    [%test_result: bool] (is_empty t) ~expect:true;
+    [%test_result: int] (length t) ~expect:0;
+    push t 13;
+    push t 14;
+    [%test_result: bool] (is_empty t) ~expect:false;
+    [%test_result: int] (length t) ~expect:2;
+    [%test_result: int list] (to_list t) ~expect:[ 14; 13 ];
+    [%test_result: int option] (min_elt ~compare:Int.compare t) ~expect:(Some 13);
+    [%test_result: int option] (max_elt ~compare:Int.compare t) ~expect:(Some 14);
+    [%test_result: int] (sum (module Int) ~f:Fn.id t) ~expect:27;
+    [%test_result: bool] (Option.is_some (pop t)) ~expect:true;
+    [%test_result: bool] (Option.is_some (pop t)) ~expect:true
+  ;;
+
+  let of_list = of_list
+
+  let%test_unit _ =
+    for n = 0 to 5 do
+      let l = List.init n ~f:Fn.id in
+      [%test_result: int list] (to_list (of_list l)) ~expect:l
+    done
+  ;;
+
+  let clear = clear
+
+  let%test_unit _ =
+    for n = 0 to 5 do
+      let t = of_list (List.init n ~f:Fn.id) in
+      clear t;
+      assert (is_empty t);
+      push t 13;
+      [%test_result: int] (length t) ~expect:1
+    done
+  ;;
+
+  let%test_unit "float test" =
+    let s = create () in
+    push s 1.0;
+    push s 2.0;
+    push s 3.0
+  ;;
+
+  let filter_map = filter_map
+
+  let%test_unit "filter_map" =
+    let s = create () in
+    push s 0;
+    push s 1;
+    push s 2;
+    push s 3;
+    [%test_result: int list] (to_list s) ~expect:[ 3; 2; 1; 0 ];
+    let s = filter_map s ~f:(fun i -> if i % 2 <> 0 then Some (i * 2) else None) in
+    [%test_result: int list] (to_list s) ~expect:[ 6; 2 ];
+    let s = filter_map s ~f:(fun i -> if i < 4 then Some (i * 2) else None) in
+    [%test_result: int list] (to_list s) ~expect:[ 4 ]
+  ;;
+
+  let filter = filter
+
+  let%test_unit "filter" =
+    let s = create () in
+    push s 0;
+    push s 1;
+    push s 2;
+    push s 3;
+    [%test_result: int list] (to_list s) ~expect:[ 3; 2; 1; 0 ];
+    let s = filter s ~f:(fun i -> i % 2 <> 0) in
+    [%test_result: int list] (to_list s) ~expect:[ 3; 1 ];
+    let s = filter s ~f:(fun i -> i < 2) in
+    [%test_result: int list] (to_list s) ~expect:[ 1 ]
+  ;;
+
+  let filter_inplace = filter_inplace
+
+  let%test_unit "filter_inplace" =
+    let s = create () in
+    push s 0;
+    push s 1;
+    push s 2;
+    push s 3;
+    [%test_result: int list] (to_list s) ~expect:[ 3; 2; 1; 0 ];
+    filter_inplace s ~f:(fun i -> i % 2 <> 0);
+    [%test_result: int list] (to_list s) ~expect:[ 3; 1 ];
+    filter_inplace s ~f:(fun i -> i < 2);
+    [%test_result: int list] (to_list s) ~expect:[ 1 ]
+  ;;
+
+  let%test_unit "filter_inplace raises after removing" =
+    let s = create () in
+    push s 0;
+    push s 1;
+    push s 2;
+    push s 3;
+    [%test_result: int list] (to_list s) ~expect:[ 3; 2; 1; 0 ];
+    assert (
+      Exn.does_raise (fun () ->
+        filter_inplace s ~f:(fun i ->
+          if Int.(i = 2) then raise_s [%message "exn"] else false)));
+    [%test_result: int list] (to_list s) ~expect:[]
+  ;;
+
+  let%test_unit "filter_inplace raises after keeping" =
+    let s = create () in
+    push s 0;
+    push s 1;
+    push s 2;
+    push s 3;
+    [%test_result: int list] (to_list s) ~expect:[ 3; 2; 1; 0 ];
+    assert (
+      Exn.does_raise (fun () ->
+        filter_inplace s ~f:(fun i ->
+          if Int.(i = 2) then raise_s [%message "exn"] else true)));
+    [%test_result: int list] (to_list s) ~expect:[ 1; 0 ]
+  ;;
+end

unikernel/duniverse/base/test/helpers/test_stack.mli

@@ -0,0 +1,3 @@
+open! Base
+module Debug (S : Stack.S) : Stack.S with type 'a t = 'a S.t
+module Test (S : Stack.S) : sig end