unikernel/duniverse/dune_/test/expect-tests/dag/dag_tests.ml

@@ -0,0 +1,245 @@
+open Stdune
+open Dune_tests_common
+
+let () = init ()
+
+type mynode = { name : string }
+
+let pp_mynode fmt n = Format.fprintf fmt "%s" n.name
+
+let%expect_test _ =
+  let open
+    Dag.Make
+      (struct
+        type t = mynode
+      end)
+      () in
+  let node data = create_node data in
+  let root = node { name = "root" } in
+  let node11 = node { name = "child 1 1" } in
+  let node12 = node { name = "child 1 2" } in
+  let node21 = node { name = "child 2 1" } in
+  let node31 = node { name = "child 3 1" } in
+  add_assuming_missing root node11;
+  add_assuming_missing root node12;
+  add_assuming_missing node12 node21;
+  add_assuming_missing node21 node31;
+  let dag_pp_mynode = pp_node pp_mynode in
+  Format.printf "%a@." dag_pp_mynode root;
+  let node41 = node { name = "child 4 1" } in
+  add_assuming_missing node31 node41;
+  Format.printf "%a@." dag_pp_mynode root;
+  let name node = (value node).name in
+  try
+    add_assuming_missing node41 root;
+    print_endline "no cycle"
+  with
+  | Cycle cycle ->
+    print_endline "cycle:";
+    let cycle = List.map cycle ~f:name in
+    List.map ~f:Pp.text cycle |> Pp.concat ~sep:Pp.space |> print;
+    [%expect
+      {|
+      (0: k=1) (root) [(2: k=1) (child 1 2) [(3: k=1) (child 2 1) [(4: k=2) (child 3 1) [
+                                                                   ]]];
+                        (1: k=1) (child 1 1) []]
+      (0: k=1) (root) [(2: k=1) (child 1 2) [(3: k=1) (child 2 1) [(4: k=2) (child 3 1) [
+                                                                   (5: k=2) (child 4 1) [
+                                                                   ]]]];
+                        (1: k=1) (child 1 1) []]
+      cycle:
+      child 4 1 child 3 1 child 2 1 child 1 2
+      root
+    |}]
+;;
+
+let rec adjacent_pairs l =
+  match l with
+  | [] | [ _ ] -> []
+  | x :: y :: rest -> (x, y) :: adjacent_pairs (y :: rest)
+;;
+
+let cycle_test variant =
+  let open
+    Dag.Make
+      (struct
+        type t = int
+      end)
+      () in
+  let node data = create_node data in
+  let edges = ref [] in
+  let add n1 n2 =
+    edges := (value n1, value n2) :: !edges;
+    add_assuming_missing n1 n2
+  in
+  let _n1 = node 1 in
+  let n2 = node 2 in
+  let n3 = node 3 in
+  (* the two variants are equivalent, but they end up taking a different code
+     path when producing the cycle for some reason (or at least they did in
+     2019-03) *)
+  (match variant with
+   | `a -> add n2 n3
+   | `b -> ());
+  let n4 = node 4 in
+  add n3 n4;
+  let n5 = node 5 in
+  add n5 n2;
+  let n6 = node 6 in
+  add n6 n3;
+  let n7 = node 7 in
+  let n8 = node 8 in
+  add n7 n8;
+  let n9 = node 9 in
+  add n8 n9;
+  let n10 = node 10 in
+  add n9 n10;
+  let n11 = node 11 in
+  add n10 n11;
+  let n12 = node 12 in
+  add n11 n12;
+  let n13 = node 13 in
+  add n12 n13;
+  let n14 = node 14 in
+  add n13 n14;
+  let n15 = node 15 in
+  add n14 n15;
+  let n16 = node 16 in
+  add n15 n16;
+  let n17 = node 17 in
+  add n16 n17;
+  let n18 = node 18 in
+  add n17 n18;
+  let n19 = node 19 in
+  add n12 n19;
+  let n20 = node 20 in
+  add n10 n20;
+  let n21 = node 21 in
+  add n20 n21;
+  let n22 = node 22 in
+  add n21 n22;
+  let n23 = node 23 in
+  add n22 n23;
+  let n24 = node 24 in
+  add n23 n24;
+  let n25 = node 25 in
+  add n24 n25;
+  let n26 = node 26 in
+  add n25 n26;
+  let n27 = node 27 in
+  add n26 n27;
+  let n28 = node 28 in
+  add n21 n28;
+  let n29 = node 29 in
+  add n10 n29;
+  let n30 = node 30 in
+  add n8 n30;
+  let _n31 = node 31 in
+  add n14 n20;
+  match add n23 n11 with
+  | _ -> assert false
+  | exception Cycle c ->
+    let c = List.map c ~f:value in
+    List.iter (adjacent_pairs c) ~f:(fun (b, a) ->
+      match List.exists !edges ~f:(fun edge -> edge = (a, b)) with
+      | true -> ()
+      | false -> Printf.ksprintf failwith "bad edge in cycle: (%d, %d)\n" a b);
+    List.map c ~f:(Pp.textf "%d") |> Pp.concat ~sep:Pp.space |> print
+;;
+
+let%expect_test _ =
+  cycle_test `a;
+  [%expect
+    {|
+    23 22 21 20 14 13 12
+    11
+  |}]
+;;
+
+let%expect_test _ =
+  cycle_test `b;
+  [%expect
+    {|
+    23 22 21 20 14 13 12
+    11
+  |}]
+;;
+
+let%expect_test "creating a cycle can succeed on the second attempt" =
+  let open
+    Dag.Make
+      (struct
+        type t = mynode
+      end)
+      () in
+  let node = create_node in
+  let c1 = node { name = "c1" } in
+  let c2 = node { name = "c2" } in
+  let c3 = node { name = "c3" } in
+  let c4 = node { name = "c4" } in
+  add_assuming_missing c1 c2;
+  add_assuming_missing c2 c3;
+  add_assuming_missing c3 c4;
+  let dag_pp_mynode = pp_node pp_mynode in
+  Format.printf "c1 = %a@.\n" dag_pp_mynode c1;
+  Format.printf "c2 = %a@.\n" dag_pp_mynode c2;
+  Format.printf "c3 = %a@.\n" dag_pp_mynode c3;
+  Format.printf "c4 = %a@.\n" dag_pp_mynode c4;
+  [%expect
+    {|
+    c1 = (0: k=1) (c1) [(1: k=1) (c2) [(2: k=1) (c3) [(3: k=2) (c4) []]]]
+
+    c2 = (1: k=1) (c2) [(2: k=1) (c3) [(3: k=2) (c4) []]]
+
+    c3 = (2: k=1) (c3) [(3: k=2) (c4) []]
+
+    c4 = (3: k=2) (c4) []
+  |}];
+  (match add_assuming_missing c4 c2 with
+   | () -> Format.printf "added :o\n"
+   | exception Cycle _ -> Format.printf "cycle\n");
+  Format.printf "c1 = %a@.\n" dag_pp_mynode c1;
+  Format.printf "c2 = %a@.\n" dag_pp_mynode c2;
+  Format.printf "c3 = %a@.\n" dag_pp_mynode c3;
+  Format.printf "c4 = %a@.\n" dag_pp_mynode c4;
+  (* Note that the state of the nodes changed even though adding the edge has
+     failed. Specifically, the levels of nodes c2 and c3 increased to 2. *)
+  [%expect
+    {|
+    cycle
+    c1 = (0: k=1) (c1) [(1: k=2) (c2) [(2: k=2) (c3) [(3: k=2) (c4) []]]]
+
+    c2 = (1: k=2) (c2) [(2: k=2) (c3) [(3: k=2) (c4) []]]
+
+    c3 = (2: k=2) (c3) [(3: k=2) (c4) []]
+
+    c4 = (3: k=2) (c4) []
+  |}];
+  (match add_assuming_missing c4 c2 with
+   | () -> Format.printf "added :o\n"
+   | exception Cycle _ -> Format.printf "cycle\n");
+  Format.printf "c1 = %a@.\n" dag_pp_mynode c1;
+  (* The output is truncated at depth 20. *)
+  [%expect
+    {|
+    added :o
+    c1 = (0: k=1) (c1) [(1: k=2) (c2) [(2: k=2) (c3) [(3: k=2) (c4) [
+                                                               (1: k=2) (c2) [
+                                                               (2: k=2) (c3) [
+                                                               (3: k=2) (c4) [
+                                                               (1: k=2) (c2) [
+                                                               (2: k=2) (c3) [
+                                                               (3: k=2) (c4) [
+                                                               (1: k=2) (c2) [
+                                                               (2: k=2) (c3) [
+                                                               (3: k=2) (c4) [
+                                                               (1: k=2) (c2) [
+                                                               (2: k=2) (c3) [
+                                                               (3: k=2) (c4) [
+                                                               (1: k=2) (c2) [
+                                                               (2: k=2) (c3) [
+                                                               (3: k=2) (c4) [
+                                                               (1: k=2) (c2) [
+                                                               ...]]]]]]]]]]]]]]]]]]]]
+  |}]
+;;

unikernel/duniverse/dune_/test/expect-tests/dag/dune

@@ -0,0 +1,15 @@
+(library
+ (name dune_dag_unit_tests)
+ (inline_tests)
+ (libraries
+  dune_tests_common
+  stdune
+  dag
+  ;; This is because of the (implicit_transitive_deps false)
+  ;; in dune-project
+  ppx_expect.config
+  ppx_expect.config_types
+  base
+  ppx_inline_test.config)
+ (preprocess
+  (pps ppx_expect)))