| 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
end
)
+exception Cycle_found
+
type dag = {
(* List of nodes. *)
nodes : node list;
| 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
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.
* 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));