unikernel/duniverse/lwt-dllist/test/dune

@@ -0,0 +1,8 @@
+(executable
+ (name main)
+ (libraries lwt lwt.unix lwt-dllist)
+ (flags (:standard -w +A-40-42)))
+
+(alias
+ (name runtest)
+ (action (run %{exe:main.exe})))

unikernel/duniverse/lwt-dllist/test/main.ml

@@ -0,0 +1 @@
+Test.run "dllist" [ Test_lwt_dllist.suite ]

unikernel/duniverse/lwt-dllist/test/test.ml

@@ -0,0 +1,211 @@
+(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
+   details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
+
+[@@@warning "-4"]
+
+type test = {
+  test_name : string;
+  skip_if_this_is_false : unit -> bool;
+  run : unit -> bool Lwt.t;
+}
+
+type outcome =
+  | Passed
+  | Failed
+  | Exception of exn
+  | Skipped
+
+exception Skip
+
+let test_direct test_name ?(only_if = fun () -> true) run =
+  let run =
+    fun () ->
+      Lwt.return (run ())
+  in
+  {test_name; skip_if_this_is_false = only_if; run}
+
+let test test_name ?(only_if = fun () -> true) run =
+  {test_name; skip_if_this_is_false = only_if; run}
+
+let run_test : test -> outcome Lwt.t = fun test ->
+  if test.skip_if_this_is_false () = false then
+    Lwt.return Skipped
+
+  else begin
+    (* Lwt.async_exception_hook handling inspired by
+         https://github.com/mirage/alcotest/issues/45 *)
+    let async_exception_promise, async_exception_occurred = Lwt.task () in
+    let old_async_exception_hook = !Lwt.async_exception_hook in
+    Lwt.async_exception_hook := (fun exn ->
+      Lwt.wakeup_later async_exception_occurred (Exception exn));
+
+    Lwt.finalize
+      (fun () ->
+
+        let test_completion_promise =
+          Lwt.try_bind
+            (fun () ->
+              test.run ())
+
+            (fun test_did_pass ->
+              if test_did_pass then
+                Lwt.return Passed
+              else
+                Lwt.return Failed)
+
+            (function
+            | Skip ->
+              Lwt.return Skipped
+
+            | exn_raised_by_test ->
+              Lwt.return (Exception exn_raised_by_test))
+        in
+
+        Lwt.pick [test_completion_promise; async_exception_promise])
+
+      (fun () ->
+        Lwt.async_exception_hook := old_async_exception_hook;
+        Lwt.return_unit)
+  end
+
+let outcome_to_character : outcome -> string = function
+  | Passed -> "."
+  | Failed -> "F"
+  | Exception _ -> "E"
+  | Skipped -> "S"
+
+
+
+type suite = {
+  suite_name : string;
+  suite_tests : test list;
+  skip_suite_if_this_is_false : unit -> bool;
+}
+
+let suite name ?(only_if = fun () -> true) tests =
+  {suite_name = name;
+   suite_tests = tests;
+   skip_suite_if_this_is_false = only_if}
+
+let run_test_suite : suite -> ((string * outcome) list) Lwt.t = fun suite ->
+  if suite.skip_suite_if_this_is_false () = false then
+    let outcomes =
+      suite.suite_tests
+      |> List.map (fun {test_name; _} -> (test_name, Skipped))
+    in
+    (outcome_to_character Skipped).[0]
+    |> String.make (List.length outcomes)
+    |> print_string;
+    flush stdout;
+
+    Lwt.return outcomes
+
+  else
+    suite.suite_tests |> Lwt_list.map_s begin fun test ->
+      Lwt.bind (run_test test) (fun outcome ->
+      outcome |> outcome_to_character |> print_string;
+      flush stdout;
+      Lwt.return (test.test_name, outcome))
+    end
+
+let outcomes_all_ok : (string * outcome) list -> bool =
+  List.for_all (fun (_test_name, outcome) ->
+    match outcome with
+    | Passed | Skipped -> true
+    | Failed | Exception _ -> false)
+
+let show_failures : (string * outcome) list -> unit =
+  List.iter (fun (test_name, outcome) ->
+    match outcome with
+    | Passed
+    | Skipped ->
+      ()
+
+    | Failed ->
+      Printf.eprintf
+        "Test '%s' produced 'false'\n" test_name
+
+    | Exception exn ->
+      Printf.eprintf
+        "Test '%s' raised '%s'\n" test_name (Printexc.to_string exn))
+
+
+
+type aggregated_outcomes = (string * ((string * outcome) list)) list
+
+let fold_over_outcomes :
+    ('a -> suite_name:string -> test_name:string -> outcome -> 'a) ->
+    'a ->
+    aggregated_outcomes ->
+      'a =
+
+    fun f init outcomes ->
+
+  List.fold_left (fun accumulator (suite_name, test_outcomes) ->
+    List.fold_left (fun accumulator (test_name, test_outcome) ->
+      f accumulator ~suite_name ~test_name test_outcome)
+      accumulator
+      test_outcomes)
+    init
+    outcomes
+
+let count_ran : aggregated_outcomes -> int =
+  fold_over_outcomes
+    (fun count ~suite_name:_ ~test_name:_ -> function
+      | Skipped ->
+        count
+      | _ ->
+        count + 1)
+    0
+
+let count_skipped : aggregated_outcomes -> int =
+  fold_over_outcomes
+    (fun count ~suite_name:_ ~test_name:_ -> function
+      | Skipped ->
+        count + 1
+      | _ ->
+        count)
+    0
+
+(* Runs a series of test suites. If one of the test suites fails, does not run
+   subsequent suites. *)
+let run library_name suites =
+  Printexc.register_printer (function
+    | Failure message -> Some (Printf.sprintf "Failure(%S)" message)
+    | _ -> None);
+
+  Printf.printf "Testing library '%s'...\n" library_name;
+
+  let rec loop_over_suites aggregated_outcomes suites =
+    match suites with
+    | [] ->
+      Printf.printf
+        "\nOk. %i tests ran, %i tests skipped\n"
+        (count_ran aggregated_outcomes)
+        (count_skipped aggregated_outcomes);
+      Lwt.return_unit
+
+    | suite::rest ->
+      Lwt.bind (run_test_suite suite) begin fun outcomes ->
+        if not (outcomes_all_ok outcomes) then begin
+          print_newline ();
+          flush stdout;
+          Printf.eprintf "Failures in test suite '%s':\n" suite.suite_name;
+          show_failures outcomes;
+          exit 1
+        end
+        else
+          loop_over_suites
+            ((suite.suite_name, outcomes)::aggregated_outcomes) rest
+      end
+  in
+
+  loop_over_suites [] suites
+  |> Lwt_main.run
+
+let with_async_exception_hook hook f =
+  let old_hook = !Lwt.async_exception_hook in
+  Lwt.async_exception_hook := hook;
+  Lwt.finalize f (fun () ->
+    Lwt.async_exception_hook := old_hook;
+    Lwt.return ())

unikernel/duniverse/lwt-dllist/test/test.mli

@@ -0,0 +1,40 @@
+(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
+   details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
+
+
+
+(** Helpers for tests. *)
+
+type test
+(** Type of a test *)
+
+type suite
+(** Type of a suite of tests *)
+
+exception Skip
+(** In some tests, it is only clear that the test should be skipped after it has
+    started running (for example, after an attempted system call raises a
+    certain exception, indicating it is not supported).
+
+    Such tests should raise [Test.Skip], or reject their final promise with
+    [Test.Skip]. *)
+
+val test_direct : string -> ?only_if:(unit -> bool) -> (unit -> bool) -> test
+(** Defines a test. [run] must returns [true] if the test succeeded
+    and [false] otherwise. [only_if] is used to conditionally skip the
+    test. *)
+
+val test : string -> ?only_if:(unit -> bool) -> (unit -> bool Lwt.t) -> test
+(** Like [test_direct], but defines a test which runs a thread. *)
+
+val suite : string -> ?only_if:(unit -> bool) -> test list -> suite
+(** Defines a suite of tests *)
+
+val run : string -> suite list -> unit
+(** Run all the given tests and exit the program with an exit code
+    of [0] if all tests succeeded and with [1] otherwise. *)
+
+val with_async_exception_hook : (exn -> unit) -> (unit -> 'a Lwt.t) -> 'a Lwt.t
+(** [Test.with_async_exception_hook hook f] sets [!Lwt.async_exception_hook] to
+    [hook], runs [f ()], and then restores [!Lwt.async_exception_hook] to its
+    former value. *)

unikernel/duniverse/lwt-dllist/test/test_lwt_dllist.ml

@@ -0,0 +1,417 @@
+(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
+   details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
+
+open Test
+
+let filled_sequence () =
+  let s = Lwt_dllist.create () in
+  let _ = Lwt_dllist.add_r 1 s in
+  let _ = Lwt_dllist.add_r 2 s in
+  let _ = Lwt_dllist.add_r 3 s in
+  let _ = Lwt_dllist.add_r 4 s in
+  let _ = Lwt_dllist.add_r 5 s in
+  let _ = Lwt_dllist.add_r 6 s in
+  s
+
+let filled_length = 6
+
+let leftmost_value = 1
+
+let rightmost_value = 6
+
+let transfer_sequence () =
+  let s = Lwt_dllist.create () in
+  let _ = Lwt_dllist.add_r 7 s in
+  let _ = Lwt_dllist.add_r 8 s in
+  s
+
+let transfer_length = 2
+
+let empty_array = [||]
+
+let l_filled_array = [|1; 2; 3; 4; 5; 6|]
+
+let r_filled_array = [|6; 5; 4; 3; 2; 1|]
+
+let factorial_sequence = 720
+
+let test_iter iter_f array_values seq =
+  let index = ref 0 in
+  Lwt.catch
+   (fun () ->
+    iter_f (fun v ->
+              assert (v = array_values.(!index));
+              index := (!index + 1)) seq;
+    Lwt.return_true)
+   (function _ -> Lwt.return_false)
+
+let test_iter_node iter_f array_values seq =
+  let index = ref 0 in
+  Lwt.catch
+   (fun () ->
+    iter_f (fun n ->
+              assert ((Lwt_dllist.get n) = array_values.(!index));
+              index := (!index + 1)) seq;
+    Lwt.return_true)
+   (function _ -> Lwt.return_false)
+
+let test_iter_rem iter_f array_values seq =
+  let index = ref 0 in
+  Lwt.catch
+   (fun () ->
+    iter_f (fun n ->
+              assert ((Lwt_dllist.get n) = array_values.(!index));
+              Lwt_dllist.remove n;
+              index := (!index + 1)) seq;
+    Lwt.return_true)
+   (function _ -> Lwt.return_false)
+
+let suite = suite "lwt_sequence" [
+
+  test "create" begin fun () ->
+    let s = Lwt_dllist.create () in
+    let _ = assert (Lwt_dllist.is_empty s) in
+    let len = Lwt_dllist.length s in
+    Lwt.return (len = 0)
+  end;
+
+  test "add_l" begin fun () ->
+    let s = Lwt_dllist.create () in
+    let n = Lwt_dllist.add_l 1 s in
+    let _ = assert ((Lwt_dllist.get n) = 1) in
+    let len = Lwt_dllist.length s in
+    Lwt.return (len = 1)
+  end;
+
+  test "add_r" begin fun () ->
+    let s = Lwt_dllist.create () in
+    let n = Lwt_dllist.add_r 1 s in
+    let _ = assert ((Lwt_dllist.get n) = 1) in
+    let len = Lwt_dllist.length s in
+    Lwt.return (len = 1)
+  end;
+
+  test "take_l Empty" begin fun () ->
+    let s = Lwt_dllist.create () in
+    Lwt.catch
+      (fun () ->
+        let _ = Lwt_dllist.take_l s in
+        Lwt.return_false)
+      (function
+        | Lwt_dllist.Empty -> Lwt.return_true
+        | _ -> Lwt.return_false)
+  end;
+
+  test "take_l" begin fun () ->
+    let s = filled_sequence () in
+    Lwt.catch
+      (fun () ->
+        let v = Lwt_dllist.take_l s in
+        Lwt.return (leftmost_value = v))
+      (function _ -> Lwt.return_false)
+  end;
+
+  test "take_r Empty" begin fun () ->
+    let s = Lwt_dllist.create () in
+    Lwt.catch
+      (fun () ->
+        let _ = Lwt_dllist.take_r s in Lwt.return_false)
+      (function
+        | Lwt_dllist.Empty -> Lwt.return_true
+        | _ -> Lwt.return_false)
+  end;
+
+  test "take_r" begin fun () ->
+    let s = filled_sequence () in
+    Lwt.catch
+      (fun () ->
+        let v = Lwt_dllist.take_r s in Lwt.return (rightmost_value = v))
+      (function _ -> Lwt.return_false)
+  end;
+
+  test "take_opt_l Empty" begin fun () ->
+    let s = Lwt_dllist.create () in
+    match Lwt_dllist.take_opt_l s with
+    | None -> Lwt.return_true
+    | _ -> Lwt.return_false
+  end;
+
+  test "take_opt_l" begin fun () ->
+    let s = filled_sequence () in
+    match Lwt_dllist.take_opt_l s with
+    | None -> Lwt.return_false
+    | Some v -> Lwt.return (leftmost_value = v)
+  end;
+
+  test "take_opt_r Empty" begin fun () ->
+    let s = Lwt_dllist.create () in
+    match Lwt_dllist.take_opt_r s with
+    | None -> Lwt.return_true
+    | _ -> Lwt.return_false
+  end;
+
+  test "take_opt_r" begin fun () ->
+    let s = filled_sequence () in
+    match Lwt_dllist.take_opt_r s with
+    | None -> Lwt.return_false
+    | Some v -> Lwt.return (rightmost_value = v)
+  end;
+
+  test "transfer_l Empty" begin fun () ->
+    let s = filled_sequence () in
+    let ts = Lwt_dllist.create () in
+    let _ = Lwt_dllist.transfer_l ts s in
+    let len = Lwt_dllist.length s in
+    Lwt.return (filled_length = len)
+  end;
+
+  test "transfer_l " begin fun () ->
+    let s = filled_sequence () in
+    let ts = transfer_sequence () in
+    let _ = Lwt_dllist.transfer_l ts s in
+    let len = Lwt_dllist.length s in
+    let _ = assert ((filled_length + transfer_length) = len) in
+    match Lwt_dllist.take_opt_l s with
+    | None -> Lwt.return_false
+    | Some v -> Lwt.return (7 = v)
+  end;
+
+  test "transfer_r Empty" begin fun () ->
+    let s = filled_sequence () in
+    let ts = Lwt_dllist.create () in
+    let _ = Lwt_dllist.transfer_r ts s in
+    let len = Lwt_dllist.length s in
+    Lwt.return (filled_length = len)
+  end;
+
+  test "transfer_r " begin fun () ->
+    let s = filled_sequence () in
+    let ts = transfer_sequence () in
+    let _ = Lwt_dllist.transfer_r ts s in
+    let len = Lwt_dllist.length s in
+    let _ = assert ((filled_length + transfer_length) = len) in
+    match Lwt_dllist.take_opt_r s with
+    | None -> Lwt.return_false
+    | Some v -> Lwt.return (8 = v)
+  end;
+
+  test "iter_l Empty" begin fun () ->
+    test_iter Lwt_dllist.iter_l empty_array (Lwt_dllist.create ())
+  end;
+
+  test "iter_l" begin fun () ->
+    test_iter Lwt_dllist.iter_l l_filled_array (filled_sequence ())
+  end;
+
+  test "iter_r Empty" begin fun () ->
+    test_iter Lwt_dllist.iter_r empty_array (Lwt_dllist.create ())
+  end;
+
+  test "iter_r" begin fun () ->
+    test_iter Lwt_dllist.iter_r r_filled_array (filled_sequence ())
+  end;
+
+  test "iter_node_l Empty" begin fun () ->
+    test_iter_node Lwt_dllist.iter_node_l empty_array (Lwt_dllist.create ())
+  end;
+
+  test "iter_node_l" begin fun () ->
+    test_iter_node Lwt_dllist.iter_node_l l_filled_array (filled_sequence ())
+  end;
+
+  test "iter_node_r Empty" begin fun () ->
+    test_iter_node Lwt_dllist.iter_node_r empty_array (Lwt_dllist.create ())
+  end;
+
+  test "iter_node_r" begin fun () ->
+    test_iter_node Lwt_dllist.iter_node_r r_filled_array (filled_sequence ())
+  end;
+
+  test "iter_node_l with removal" begin fun () ->
+    test_iter_rem Lwt_dllist.iter_node_l l_filled_array (filled_sequence ())
+  end;
+
+  test "iter_node_r with removal" begin fun () ->
+    test_iter_rem Lwt_dllist.iter_node_r r_filled_array (filled_sequence ())
+  end;
+
+  test "fold_l" begin fun () ->
+    let acc = Lwt_dllist.fold_l (fun v e -> v * e) (filled_sequence ()) 1 in
+    Lwt.return (factorial_sequence = acc)
+  end;
+
+  test "fold_l Empty" begin fun () ->
+    let acc = Lwt_dllist.fold_l (fun v e -> v * e) (Lwt_dllist.create ()) 1 in
+    Lwt.return (acc = 1)
+  end;
+
+  test "fold_r" begin fun () ->
+    let acc = Lwt_dllist.fold_r (fun v e -> v * e) (filled_sequence ()) 1 in
+    Lwt.return (factorial_sequence = acc)
+  end;
+
+  test "fold_r Empty" begin fun () ->
+    let acc = Lwt_dllist.fold_r (fun v e -> v * e) (Lwt_dllist.create ()) 1 in
+    Lwt.return (acc = 1)
+  end;
+
+  test "find_node_opt_l Empty" begin fun () ->
+    let s = Lwt_dllist.create () in
+    match Lwt_dllist.find_node_opt_l (fun v -> v = 1) s with
+    | None -> Lwt.return_true
+    | _ -> Lwt.return_false
+  end;
+
+  test "find_node_opt_l not found " begin fun () ->
+    let s = transfer_sequence () in
+    match Lwt_dllist.find_node_opt_l (fun v -> v = 1) s with
+    | None -> Lwt.return_true
+    | _ -> Lwt.return_false
+  end;
+
+  test "find_node_opt_l" begin fun () ->
+    let s = filled_sequence () in
+    match Lwt_dllist.find_node_opt_l (fun v -> v = 1) s with
+    | None -> Lwt.return_false
+    | Some n -> if ((Lwt_dllist.get n) = 1) then Lwt.return_true
+      else Lwt.return_false
+  end;
+
+  test "find_node_opt_r Empty" begin fun () ->
+    let s = Lwt_dllist.create () in
+    match Lwt_dllist.find_node_opt_r (fun v -> v = 1) s with
+    | None -> Lwt.return_true
+    | _ -> Lwt.return_false
+  end;
+
+  test "find_node_opt_r not found " begin fun () ->
+    let s = transfer_sequence () in
+    match Lwt_dllist.find_node_opt_r (fun v -> v = 1) s with
+    | None -> Lwt.return_true
+    | _ -> Lwt.return_false
+  end;
+
+  test "find_node_opt_r" begin fun () ->
+    let s = filled_sequence () in
+    match Lwt_dllist.find_node_opt_r (fun v -> v = 1) s with
+    | None -> Lwt.return_false
+    | Some n -> if ((Lwt_dllist.get n) = 1) then Lwt.return_true
+      else Lwt.return_false
+  end;
+
+  test "find_node_l Empty" begin fun () ->
+    let s = Lwt_dllist.create () in
+    Lwt.catch
+    (fun () -> let n = Lwt_dllist.find_node_l (fun v -> v = 1) s in
+       if ((Lwt_dllist.get n) = 1) then Lwt.return_false
+       else Lwt.return_false)
+    (function
+      | Not_found -> Lwt.return_true
+      | _ -> Lwt.return_false)
+  end;
+
+  test "find_node_l" begin fun () ->
+    let s = filled_sequence () in
+    Lwt.catch
+    (fun () -> let n = Lwt_dllist.find_node_l (fun v -> v = 1) s in
+       if ((Lwt_dllist.get n) = 1) then Lwt.return_true
+       else Lwt.return_false)
+    (function _ -> Lwt.return_false)
+  end;
+
+  test "find_node_r Empty" begin fun () ->
+    let s = Lwt_dllist.create () in
+    Lwt.catch
+    (fun () -> let n = Lwt_dllist.find_node_r (fun v -> v = 1) s in
+       if ((Lwt_dllist.get n) = 1) then Lwt.return_false
+       else Lwt.return_false)
+    (function
+      | Not_found -> Lwt.return_true
+      | _ -> Lwt.return_false)
+  end;
+
+  test "find_node_r" begin fun () ->
+    let s = filled_sequence () in
+    Lwt.catch
+    (fun () -> let n = Lwt_dllist.find_node_r (fun v -> v = 1) s in
+       if ((Lwt_dllist.get n) = 1) then Lwt.return_true
+       else Lwt.return_false)
+    (function _ -> Lwt.return_false)
+  end;
+
+  test "set" begin fun () ->
+    let s = filled_sequence () in
+    match Lwt_dllist.find_node_opt_l (fun v -> v = 4) s with
+    | None -> Lwt.return_false
+    | Some n -> let _ = Lwt_dllist.set n 10 in
+      let data = [|1; 2; 3; 10; 5; 6|] in
+      test_iter Lwt_dllist.iter_l data s
+  end;
+
+  test "fold_r with multiple removal" begin fun () ->
+    let s = filled_sequence () in
+    let n_three = Lwt_dllist.find_node_r (fun v' -> v' = 3) s in
+    let n_two = Lwt_dllist.find_node_r (fun v' -> v' = 2) s in
+    let n_four = Lwt_dllist.find_node_r (fun v' -> v' = 4) s in
+    let acc = Lwt_dllist.fold_r begin fun v e ->
+      if v = 3 then begin
+         let _ = Lwt_dllist.remove n_three in
+         let _ = Lwt_dllist.remove n_two in
+         ignore(Lwt_dllist.remove n_four)
+      end;
+      v * e
+    end s 1 in
+    Lwt.return (acc = (factorial_sequence / 2))
+  end;
+
+  test "fold_l multiple removal" begin fun () ->
+   let s = filled_sequence () in
+   let n_four = Lwt_dllist.find_node_r (fun v' -> v' = 4) s in
+   let n_five = Lwt_dllist.find_node_r (fun v' -> v' = 5) s in
+   let n_three = Lwt_dllist.find_node_r (fun v' -> v' = 3) s in
+   let acc = Lwt_dllist.fold_l begin fun v e ->
+      if v = 4 then begin
+         let _ = Lwt_dllist.remove n_four in
+         let _ = Lwt_dllist.remove n_five in
+         ignore(Lwt_dllist.remove n_three)
+      end;
+      v * e
+   end s 1 in
+    Lwt.return (acc = (factorial_sequence / 5))
+  end;
+
+  test "find_node_r with multiple removal" begin fun () ->
+    let s = filled_sequence () in
+    let n_three = Lwt_dllist.find_node_r (fun v' -> v' = 3) s in
+    let n_two = Lwt_dllist.find_node_r (fun v' -> v' = 2) s in
+    Lwt.catch
+    begin fun () ->
+      let n = Lwt_dllist.find_node_r begin fun v ->
+        if v = 3 then (
+          let _ = Lwt_dllist.remove n_three in
+          ignore(Lwt_dllist.remove n_two));
+        v = 1
+       end s in
+      let v = Lwt_dllist.get n in
+      Lwt.return (v = 1)
+    end
+    (function _ -> Lwt.return_false)
+  end;
+
+  test "find_node_l with multiple removal" begin fun () ->
+    let s = filled_sequence () in
+    let n_three = Lwt_dllist.find_node_r (fun v' -> v' = 3) s in
+    let n_four = Lwt_dllist.find_node_r (fun v' -> v' = 4) s in
+    Lwt.catch
+    begin fun () ->
+      let n = Lwt_dllist.find_node_l begin fun v ->
+        if v = 3 then (
+          let _ = Lwt_dllist.remove n_three in
+          ignore(Lwt_dllist.remove n_four));
+        v = 6 end s in
+      let v = Lwt_dllist.get n in
+      Lwt.return (v = 6)
+    end
+    (function _ -> Lwt.return_false)
+  end;
+]