Detect cycles in type declarations

[tiger.ml.git] / compiler / src / lib / tiger / tiger_dag.ml

diff --git a/compiler/src/lib/tiger/tiger_dag.ml b/compiler/src/lib/tiger/tiger_dag.ml
new file mode 100644 (file)
index 0000000..f843506
--- /dev/null
+++ b/compiler/src/lib/tiger/tiger_dag.ml
@@ -0,0 +1,39 @@
+module List = ListLabels
+
+module Map = Tiger_map
+module Opt = Tiger_opt
+
+type t =
+  unit
+
+type count =
+  { parents  : int
+  ; children : int
+  }
+
+let of_list pairs =
+  let incr counts k incr =
+    let prev = Opt.get (Map.get counts ~k) ~default:{parents=0; children=0} in
+    Map.set counts ~k ~v:(incr prev)
+  in
+  let incr_parents  count = {count with parents  = succ count.parents} in
+  let incr_children count = {count with children = succ count.children} in
+  let zero_children counts =
+    List.filter (Map.to_list counts) ~f:(fun (_, {children=c; _}) -> c = 0 )
+  in
+  let zero_parents counts =
+    List.filter (Map.to_list counts) ~f:(fun (_, {parents=p; _}) -> p = 0 )
+  in
+  let counts =
+    List.fold_left pairs ~init:Map.empty ~f:(
+      fun counts (p, c) ->
+        let counts = incr counts p incr_children in
+        let counts = incr counts c incr_parents  in
+        counts
+    )
+  in
+  (* At least one node with no in-coming links and
+   * at least one node with no out-going links. *)
+  match (zero_parents counts, zero_children counts) with
+  | _ :: _, _ :: _ -> Ok ()
+  |      _,      _ -> Error `Cycle