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/src/dot_V1.ml b/src/dot_V1.ml new file mode 100644 index 00000000..86e37754 --- /dev/null +++ b/src/dot_V1.ml @@ -0,0 +1,214 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* 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.1, 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. *) +(* *) +(**************************************************************************) + +(** Parser for DOT file format *) +open Dot_ast + +let parse_dot_ast_from_chan c = + let lb = Lexing.from_channel c in + let dot = + try + Dot_parser.file Dot_lexer.token lb + with Parsing.Parse_error -> + let n = Lexing.lexeme_start lb in + failwith (Printf.sprintf "Dot.parse: parse error character %d" n) + in + close_in c; + dot + +let parse_dot_ast f = + let c = open_in f in + parse_dot_ast_from_chan c + +type clusters_hash = (string, attr list) Hashtbl.t + +let get_string = function + | String s -> s + | Ident s -> s + | Number s -> s + | Html s -> s + +module Parse + (B : Builder.S) + (L : sig + val node : node_id -> attr list -> B.G.V.label + (** how to build the node label out of the set of attributes *) + + val edge : attr list -> B.G.E.label + (** how to build the edge label out of the set of attributes *) + end) = +struct + + module Attr = struct + module M = + Map.Make + (struct + type t = id + let compare : t -> t -> int = Stdlib.compare + end) + let empty = M.empty + let add = List.fold_left (fun a (x,v) -> M.add x v a) + let addl = List.fold_left add + let list a = M.fold (fun x v l -> (x,v) :: l) a [] + end + + let create_graph_and_clusters dot = + (* pass 1*) + + (* collect node attributes *) + let def_node_attr = ref Attr.empty in + let node_attr = Hashtbl.create 97 in + + (* collect cluster attributes *) + let def_clust_attr = ref Attr.empty in + let clust_attr = Hashtbl.create 97 in + + (* collect clusters nodes *) + let clust_nodes = Hashtbl.create 97 in + + let add_node_attr id al = + let l = try Hashtbl.find node_attr id + with Not_found -> !def_node_attr in + Hashtbl.replace node_attr id (Attr.addl l al) in + + let add_clust_attr id_opt al = + match id_opt with + | Some id -> + let s = get_string id in + let l = try Hashtbl.find clust_attr s + with Not_found -> !def_clust_attr in + 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 rec collect_node_attr 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 + | Edge_stmt (NodeId id, nl, _) -> + add_node_attr id []; + List.iter (function | NodeId id -> add_node_attr id [] + | _ -> ()) nl + | Subgraph (SubgraphDef (id, stmts)) -> + collect_node_attr (Some id) stmts + | Attr_graph al -> + begin match cluster_op with + | Some id -> add_clust_attr id al + | None -> () + end + | _ -> () + ) stmts + in + collect_node_attr None dot.stmts; + + (* pass 2: build the graph and the clusters *) + let def_edge_attr = ref Attr.empty in + let nodes = Hashtbl.create 97 in + let node g id _ = + try + g, Hashtbl.find nodes id + with Not_found -> + let l = try Hashtbl.find node_attr id with Not_found -> Attr.empty in + let n = B.G.V.create (L.node id [Attr.list l]) in + Hashtbl.add nodes id n; + B.add_vertex g n, n + in + let rec add_stmts g stmts = + List.fold_left + (fun g s -> match s with + | Node_stmt (id, al) -> + let g,_ = node g id al in g + | Edge_stmt (NodeId id, nl, al) -> + let al = Attr.addl !def_edge_attr al in + let el = L.edge [Attr.list al] in + let g,vn = node g id [] in + fst (List.fold_left + (fun (g,pvn) m -> match m with + | NodeId idm -> + let g,vm = node g idm [] in + let e = B.G.E.create pvn el vm in + ((B.add_edge_e g e),vm) + | NodeSub _ -> + (g,pvn)) + (g,vn) nl) + | Attr_edge al -> + def_edge_attr := Attr.addl !def_edge_attr al; g + | Subgraph (SubgraphDef (_, stmts)) -> + add_stmts g stmts + | _ -> g + ) + g stmts in + + let graph = add_stmts (B.empty ()) dot.stmts in + + let clusters_hash = + let h = Hashtbl.create 30 in + Hashtbl.iter (fun k a -> Hashtbl.add h k [Attr.list a]) clust_attr; + h in + + graph, clusters_hash + + let get_graph_bb stmts = + let graph_bb = ref None in + let read_attr = function + | (Ident "bb" , Some (String bb)) -> graph_bb := Some bb + | _ -> () in + let read_stmt = function + | Attr_graph attrs -> List.iter (List.iter read_attr) attrs + | _ -> () in + List.iter read_stmt stmts; + !graph_bb + + let parse_dot_from_chan c = + let lb = Lexing.from_channel c in + let dot = + try + Dot_parser.file Dot_lexer.token lb + with Parsing.Parse_error -> + let n = Lexing.lexeme_start lb in + failwith (Printf.sprintf "Dot.parse: parse error character %d" n) + in + close_in c; + dot + + let parse_dot f = + let c = open_in f in + parse_dot_from_chan c + + let parse f = + fst (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 + match get_graph_bb dot.stmts with + | Some bounding_box -> + graph, bounding_box, clusters + | None -> + failwith "Cannot read bounding box in xdot file" + +end diff --git a/src/dot_V1.mli b/src/dot_V1.mli new file mode 100644 index 00000000..3fcf990c --- /dev/null +++ b/src/dot_V1.mli @@ -0,0 +1,47 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* 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.1, 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. *) +(* *) +(**************************************************************************) + +(** Parser for DOT file format. *) + +open Dot_ast + +val parse_dot_ast : string -> Dot_ast.file + +type clusters_hash = (string, attr list) Hashtbl.t + +(** Provide a parser for DOT file format. *) +module Parse + (B : Builder.S) + (L : sig + val node : node_id -> attr list -> B.G.V.label + (** How to build the node label out of the set of attributes *) + + val edge : attr list -> B.G.E.label + (** How to build the edge label out of the set of attributes *) + + end) : +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_bounding_box_and_clusters : + string -> B.G.t * string * clusters_hash + +end diff --git a/src/graph.ml b/src/graph.ml index 5f374dcb..f88df11f 100644 --- a/src/graph.ml +++ b/src/graph.ml @@ -24,6 +24,7 @@ module Dominator = Dominator module Graphviz = Graphviz module Gml = Gml module Dot = Dot +module Dot_V1 = Dot_V1 module Pack = Pack module Gmap = Gmap module Minsep = Minsep 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/dot_parse.ml b/tests/dot_parse.ml new file mode 100644 index 00000000..51287ede --- /dev/null +++ b/tests/dot_parse.ml @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* 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 P = 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 + +module DotInput = Dot.Parse (B) (P) +module DotInput_V1 = Dot_V1.Parse (B) (P) + +let g, _, _ = DotInput.parse_all Sys.argv.(1) +let g_v1 = DotInput_V1.parse Sys.argv.(1) + +let include_vertex g1 g2 = + G.fold_vertex (fun v1 is_mem -> is_mem && G.mem_vertex g2 v1) g1 true + +let include_edge g1 g2 = + G.fold_edges_e (fun e1 is_mem -> is_mem && G.mem_edge_e g2 e1) g1 true + +let quasi_equal_graph g1 g2 = + (G.nb_edges g1 = G.nb_edges g2) + && (G.nb_vertex g1 = G.nb_vertex g2) + (* && include_vertex g1 g2 + && include_edge g1 g2 *) + +let () = assert (quasi_equal_graph g g_v1) diff --git a/tests/dune b/tests/dune index ba9e0732..1dc78f2c 100644 --- a/tests/dune +++ b/tests/dune @@ -239,6 +239,8 @@ ;; rules for the dot test +; dot has a dot parser and dummy edge attribute display + (rule (deps dot.dot) (action @@ -258,6 +260,41 @@ (modules dot) (libraries graph)) +; dot_2.dot has graph and subgraphs attributes + +(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)) + +(rule + (alias dot_parse) + (deps + (glob_files "../editor/tests/*.dot") + (glob_files "../dgraph/examples/*.dot")) + (action + (ignore-stdout + (run ./dot_parse.exe %{deps})))) + +(executable + (name dot_parse) + (modules dot_parse) + (libraries graph)) + ;; rules for the running the benchmark (rule