diff --git a/src/dot.ml b/src/dot.ml index 9eaf0df8..231eabb1 100644 --- a/src/dot.ml +++ b/src/dot.ml @@ -37,6 +37,14 @@ let parse_dot_ast f = type clusters_hash = (string, attr list) Hashtbl.t +type graph = { + sg_nodes : string list; + sg_attr : attr list; + sg_parent : string option; +} + +type graph_hash = (string option, graph) Hashtbl.t + let get_string = function | String s -> s | Ident s -> s @@ -67,6 +75,19 @@ struct let list a = M.fold (fun x v l -> (x,v) :: l) a [] end + module Node_set = Set.Make( + (struct + type t = string + let compare : t -> t -> int = Stdlib.compare + end) + ) + + type graph_working = { + nodes : Node_set.t; + attr : id option Attr.M.t; + parent : string option; + } + let create_graph_and_clusters dot = (* pass 1*) @@ -79,7 +100,7 @@ struct let clust_attr = Hashtbl.create 97 in (* collect clusters nodes *) - let clust_nodes = Hashtbl.create 97 in + let graph_hash = Hashtbl.create 97 in let add_node_attr id al = let l = try Hashtbl.find node_attr id @@ -95,36 +116,75 @@ struct Hashtbl.replace clust_attr s (Attr.addl l al) | _ -> () in - let add_clust_node id_cluster id_node = - let id_nodes = try Hashtbl.find clust_nodes id_cluster - with Not_found -> [] in - Hashtbl.add clust_nodes id_cluster (id_node :: id_nodes) in + let add_clust_node parent cluster_op (id_node, _) = + let strip_cluster_prefix id = + let s = get_string id in + if String.starts_with ~prefix:"cluster_" s then + String.sub s 8 (String.length s - 8) + else + s in + let valid_cluster_id_of_cluster_id cluster_id = + match cluster_id with + | Some (Some id) -> Some (Some (strip_cluster_prefix id)) + | Some None -> None + | None -> Some None + in + let string_opt_of_cluster_id cluster_id = + match cluster_id with + | Some (Some id) -> Some (strip_cluster_prefix id) + | Some None -> (* UNREACHABLE *) None + | None -> None + in + match valid_cluster_id_of_cluster_id cluster_op with + | Some s_cluster -> + begin + let subgraph = try Hashtbl.find graph_hash s_cluster + with Not_found -> + { nodes = Node_set.empty; + attr = Attr.empty; + parent = string_opt_of_cluster_id parent} in + let subgraph_new = { + subgraph with + nodes = Node_set.add (get_string id_node) subgraph.nodes + } in + Hashtbl.replace graph_hash s_cluster subgraph_new + end + | None -> () in - let rec collect_node_attr cluster_op stmts = + let rec collect_attr parent cluster_op stmts = List.iter ( function | Node_stmt (id, al) -> add_node_attr id al; - begin match cluster_op with - | Some id_cluster -> add_clust_node id_cluster id - | _ -> () - end - | Attr_node al -> def_node_attr := Attr.addl !def_node_attr al + add_clust_node parent cluster_op id | Edge_stmt (NodeId id, nl, _) -> add_node_attr id []; - List.iter (function | NodeId id -> add_node_attr id [] + add_clust_node parent cluster_op id; + List.iter (function | NodeId id -> + add_node_attr id []; + add_clust_node parent cluster_op id | _ -> ()) nl - | Subgraph (SubgraphDef (id, stmts)) -> - collect_node_attr (Some id) stmts + | Edge_stmt (NodeSub _, _, _) -> () | Attr_graph al -> begin match cluster_op with | Some id -> add_clust_attr id al - | None -> () + | None -> (* failwith "UNREACHABLE" *) () end + | Attr_node al -> def_node_attr := Attr.addl !def_node_attr al + | Attr_edge _ -> () + | Equal (al_key, al_val) -> + let al = [[al_key, Some al_val]] in + begin match cluster_op with + | Some id -> add_clust_attr id al + | None -> add_clust_attr None al + end + | Subgraph (SubgraphDef (id, stmts)) -> + collect_attr cluster_op (Some id) stmts + (* | Subgraph (SubgraphId _) -> () *) | _ -> () ) stmts in - collect_node_attr None dot.stmts; + collect_attr None None dot.stmts; (* pass 2: build the graph and the clusters *) let def_edge_attr = ref Attr.empty in @@ -171,7 +231,18 @@ struct Hashtbl.iter (fun k a -> Hashtbl.add h k [Attr.list a]) clust_attr; h in - graph, clusters_hash + let graph_hash_out = + let h = Hashtbl.create 30 in + let graph_of_graph_working gw : graph = + { sg_nodes = List.of_seq (Node_set.to_seq gw.nodes); + sg_attr = [Attr.list gw.attr]; + sg_parent = gw.parent; + } + in + Hashtbl.iter (fun k gw -> Hashtbl.add h k (graph_of_graph_working gw)) graph_hash; + h in + + graph, clusters_hash, graph_hash_out let get_graph_bb stmts = let graph_bb = ref None in @@ -201,11 +272,15 @@ struct parse_dot_from_chan c let parse f = - fst (create_graph_and_clusters (parse_dot f)) + let fst, _, _ = (create_graph_and_clusters (parse_dot f)) in + fst + + let parse_all f = + create_graph_and_clusters (parse_dot f) let parse_bounding_box_and_clusters f = let dot = parse_dot f in - let graph, clusters = create_graph_and_clusters dot in + let graph, clusters, _ = create_graph_and_clusters dot in match get_graph_bb dot.stmts with | Some bounding_box -> graph, bounding_box, clusters diff --git a/src/dot.mli b/src/dot.mli index 3fcf990c..9d02cb0d 100644 --- a/src/dot.mli +++ b/src/dot.mli @@ -21,8 +21,18 @@ open Dot_ast val parse_dot_ast : string -> Dot_ast.file +val get_string : Dot_ast.id -> string + type clusters_hash = (string, attr list) Hashtbl.t +type graph = { + sg_nodes : string list; + sg_attr : attr list; + sg_parent : string option; +} + +type graph_hash = (string option, graph) Hashtbl.t + (** Provide a parser for DOT file format. *) module Parse (B : Builder.S) @@ -39,6 +49,11 @@ sig (** Parses a dot file *) val parse : string -> B.G.t + (** Parses a dot file and returns the graph, its bounding box and + a hash table from clusters to dot attributes *) + val parse_all : + string -> B.G.t * clusters_hash * graph_hash + (** Parses a dot file and returns the graph, its bounding box and a hash table from clusters to dot attributes *) val parse_bounding_box_and_clusters : diff --git a/tests/dot_2.dot b/tests/dot_2.dot new file mode 100644 index 00000000..128bd65b --- /dev/null +++ b/tests/dot_2.dot @@ -0,0 +1,37 @@ +digraph D { + label="diagram_label"; + + // should be override + bgcolor=red; + + node [color=green]; + before_subgraph -> green + + subgraph cluster_1 { + bgcolor=lightgrey; + label="cluster_1"; + + in_subgraph1 -> green + + node [color=blue]; + in_subgraph1 -> blue + } + + after_subgraph -> green + + // should override bgcolor + bgcolor=pink; + + // subgraph without ID + subgraph cluster_2 { + // will be ignored + bgcolor=blue; + label="noname_1"; + + // will affect nodes + node [color=white]; + + in_subgraph2 -> white; + } + +} \ No newline at end of file diff --git a/tests/dot_2.expected b/tests/dot_2.expected new file mode 100644 index 00000000..c11163b0 --- /dev/null +++ b/tests/dot_2.expected @@ -0,0 +1,23 @@ +========= BEGIN output graph ========= +digraph G { + "before_subgraph"; + "green"; + "in_subgraph1"; + "blue"; + "after_subgraph"; + "in_subgraph2"; + "white"; + + subgraph cluster_1 { "blue";"in_subgraph1";"green"; + }; + subgraph cluster_2 { "white";"in_subgraph2"; + }; + + "before_subgraph" -> "green" [label=, ]; + "in_subgraph1" -> "green" [label=, ]; + "in_subgraph1" -> "blue" [label=, ]; + "after_subgraph" -> "green" [label=, ]; + "in_subgraph2" -> "white" [label=, ]; + + } +========= END output graph ========= \ No newline at end of file diff --git a/tests/dot_2.ml b/tests/dot_2.ml new file mode 100644 index 00000000..e1edae9e --- /dev/null +++ b/tests/dot_2.ml @@ -0,0 +1,69 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id:$ *) + +open Graph +module G = Imperative.Digraph.Abstract(String) +module B = Builder.I(G) +module DotInput = + Dot.Parse + (B) + (struct + let node (id,_) _ = match id with + | Dot_ast.Ident s + | Dot_ast.Number s + | Dot_ast.String s + | Dot_ast.Html s -> s + let edge _ = () + end) + +let g, _, gh = DotInput.parse_all Sys.argv.(1) + +module Display = struct + include G + let vertex_name v = "\"" ^ String.escaped (V.label v) ^ "\"" + let graph_attributes _ = [] + let default_vertex_attributes _ = [] + let vertex_attributes _ = [] + let default_edge_attributes _ = [] + let edge_attributes _ = [ `HtmlLabel "f$oo" ] + let get_subgraph v = + let graphviz_graph_of_dot_graph graph_id (dg : Dot.graph) : Graphviz.DotAttributes.subgraph = + { sg_name = graph_id; + sg_attributes = []; + sg_parent = dg.sg_parent; + } in + gh + |> Hashtbl.to_seq + |> Seq.find_map (fun (graph_id_opt, (graph : Dot.graph)) -> + match graph_id_opt with + | Some graph_id -> begin + match List.find_opt (fun n -> n = (V.label v)) graph.sg_nodes with + | Some _ -> Some (graphviz_graph_of_dot_graph graph_id graph) + | None -> None + end + | None -> None + ) + +end +module DotOutput = Graphviz.Dot(Display) + +let () = + Printf.printf "========= BEGIN output graph =========\n"; + DotOutput.output_graph stdout g; + Printf.printf "========= END output graph =========" \ No newline at end of file diff --git a/tests/dune b/tests/dune index 840bf7b2..8f27157a 100644 --- a/tests/dune +++ b/tests/dune @@ -253,6 +253,30 @@ (modules dot) (libraries graph)) +(rule + (deps dot_2.dot) + (action + (with-stdout-to + dot_2.output + (run ./dot_2.exe %{deps})))) + +(rule + (alias runtest) + (action + (progn + (diff dot_2.expected dot_2.output) + (echo "dot: all tests succeeded.\n")))) + +(executable + (name dot_2) + (modules dot_2) + (libraries graph)) + +(executable + (name dot_3) + (modules dot_3) + (libraries graph)) + ;; rules for the running the benchmark (rule