X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=src%2Fdeps.ml;h=088c64ded03f246c96750649ce69744df6319d08;hb=HEAD;hp=0795cf813dd3e6062d7f347cc0e6b12f18100950;hpb=5e13f1e2a3dc1237fcf2fa141d8379bdd36bde61;p=goals.git

diff --git a/src/deps.ml b/src/deps.ml
index 0795cf8..088c64d 100644
--- 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;
@@ -77,9 +83,40 @@ and add_node { nodes; edges } ?parent data =
     | Some parent ->
        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
+       else (
+         (* We are going to add an edge from parent -> node.  To
+          * ensure we don't make a cycle, check there is no path
+          * already from node -> parent.
+          *)
+         (match exists_path node parent edges with
+          | None -> ()
+          | Some nodes ->
+             let loc = loc_of_node data in
+             failwithf "%a: dependency cycle: %s -> %s"
+               Ast.string_loc loc
+               (String.concat " -> " (List.map string_of_node nodes))
+               (string_of_node data)
+         );
+         G.add parent (node :: children) edges
+       ) in
   node, { nodes; edges }
 
+(* Is there a path from n1 to n2 in edges?
+ * Returns [None] if no path, or [Some nodes] if there is a path.
+ *)
+and exists_path n1 n2 edges =
+  if compare_nodes n1 n2 = 0 then Some [n2]
+  else (
+    let children = try G.find n1 edges with Not_found -> [] in
+    let path =
+      List.find_map (
+        fun n -> exists_path n n2 edges
+      ) children in
+    match path with
+    | None -> None
+    | Some nodes -> Some (n1 :: nodes)
+  )
+
 (* This is Khan's algorithm. *)
 and topological_sort dag =
   let incoming_map = incoming_map dag in
@@ -108,11 +145,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 +205,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));