Detect dependency cycles earlier and print a better error.

[goals.git] / src / deps.ml

diff --git a/src/deps.ml b/src/deps.ml
index 0795cf8..1911499 100644 (file)
--- a/src/deps.ml
+++ b/src/deps.ml
@@ -30,6 +30,10 @@ let string_of_node = function
   | Goal (_, _, _, _, _, _, debug_goal) -> debug_goal
   | Exists (_, _, _, debug_pred) -> debug_pred
 
+let loc_of_node = function
+  | Goal (_, loc, _, _, _, _, _)
+  | Exists (_, loc, _, _) -> loc
+
 let compare_nodes n1 n2 =
   match n1, n2 with
   | Goal _, Exists _ -> -1
@@ -45,6 +49,8 @@ module G = Map.Make (
   end
 )
 
+exception Cycle_found
+
 type dag = {
   (* List of nodes. *)
   nodes : node list;
@@ -78,7 +84,18 @@ and add_node { nodes; edges } ?parent data =
        let children = try G.find parent edges with Not_found -> [] in
        if List.mem node children then edges
        else G.add parent (node :: children) edges in
-  node, { nodes; edges }
+  (* Doing this checks if we have added a cycle.  There may be
+   * cheaper ways to do this, see:
+   * https://stackoverflow.com/questions/20246417/how-to-detect-if-adding-an-edge-to-a-directed-graph-results-in-a-cycle
+   *)
+  let dag = { nodes; edges } in
+  (try ignore (topological_sort dag)
+   with Cycle_found ->
+     let loc = loc_of_node data in
+     failwithf "%a: adding %s creates a dependency cycle"
+       Ast.string_loc loc (string_of_node data)
+  );
+  node, dag
 
 (* This is Khan's algorithm. *)
 and topological_sort dag =
@@ -108,11 +125,7 @@ and topological_sort dag =
   in
   let dag, acc = loop dag [] incoming_map q in
 
-  if not (G.is_empty dag.edges) then
-    (* XXX More debugging to help out users!  I believe the remaining
-     * edges should demonstrate the cycle.
-     *)
-    failwithf "dependency graph contains cycles";
+  if not (G.is_empty dag.edges) then raise Cycle_found;
 
   (* This builds the topological list in reverse order, but that's
    * fine because that is the running order.
@@ -172,7 +185,9 @@ let rec create env roots =
    * is a good idea, so this function will fail if any cycle is
    * found.  We may wish to revisit this decision in future.
    *)
-  let sorted = topological_sort dag in
+  let sorted =
+    try topological_sort dag
+    with Cycle_found -> failwithf "dependency graph contains cycles" in
   if Cmdline.debug_flag () then
     eprintf "dependency order:\n  %s\n"
       (String.concat " <- " (List.map string_of_node sorted));