Add subgraph hashi n dot parser.

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

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 :

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;
+  }
+
+}

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=<f&#36;oo>, ];
+  "in_subgraph1" -> "green" [label=<f&#36;oo>, ];
+  "in_subgraph1" -> "blue" [label=<f&#36;oo>, ];
+  "after_subgraph" -> "green" [label=<f&#36;oo>, ];
+  "in_subgraph2" -> "white" [label=<f&#36;oo>, ];
+
+  }
+========= END output graph =========

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 ========="

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