This commit was manufactured by cvs2svn to create branch 'jocamltrunk'.

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/jocamltrunk@6332 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

1 files changed, 130 insertions, 0 deletions

diff --git a/ocamldoc/odoc_dot.ml b/ocamldoc/odoc_dot.ml
new file mode 100644
index 0000000000..877a84b913
--- /dev/null
+++ b/ocamldoc/odoc_dot.ml
@@ -0,0 +1,130 @@
+(***********************************************************************)
+(*                               Ocamldoc                              *)
+(*                                                                     *)
+(*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Definition of a class which outputs a dot file showing 
+   top modules dependencies.*)
+
+open Odoc_info
+
+module F = Format
+
+(** This class generates a dot file showing the top modules dependencies. *)
+class dot =
+  object (self)
+
+    (** To store the colors associated to locations of modules. *)
+    val mutable loc_colors = []
+
+    (** the list of modules we know. *)
+    val mutable modules = []
+
+    (** Colors to use when finding new locations of modules. *)
+    val mutable colors = !Args.dot_colors
+
+    (** Graph header. *)
+    method header = 
+      "digraph G {\n"^
+      "  size=\"10,7.5\";\n"^
+      "  ratio=\"fill\";\n"^
+      "  rotate=90;\n"^
+      "  fontsize=\"12pt\";\n"^
+      "  rankdir = TB ;\n"
+
+    method get_one_color =
+      match colors with
+        [] -> None
+      | h :: q -> 
+          colors <- q ;
+          Some h
+
+    method node_color s =
+      try Some (List.assoc s loc_colors)
+      with
+        Not_found -> 
+          match self#get_one_color with
+            None -> None
+          | Some c ->
+              loc_colors <- (s, c) :: loc_colors ;
+              Some c
+
+    method print_module_atts fmt m =
+      match self#node_color (Filename.dirname m.Module.m_file) with
+        None -> ()
+      | Some col -> F.fprintf fmt "\"%s\" [style=filled, color=%s];\n" m.Module.m_name col
+
+    method print_type_atts fmt t =
+      match self#node_color (Name.father t.Type.ty_name) with
+        None -> ()
+      | Some col -> F.fprintf fmt "\"%s\" [style=filled, color=%s];\n" t.Type.ty_name col
+
+    method print_one_dep fmt src dest =
+      F.fprintf fmt "\"%s\" -> \"%s\";\n" src dest
+
+    method generate_for_module fmt m =
+      let l = List.filter 
+          (fun n -> 
+            !Args.dot_include_all or 
+            (List.exists (fun m -> m.Module.m_name = n) modules)) 
+          m.Module.m_top_deps
+      in
+      self#print_module_atts fmt m;
+      List.iter (self#print_one_dep fmt m.Module.m_name) l
+
+    method generate_for_type fmt (t, l) =
+      self#print_type_atts fmt t;
+      List.iter
+        (self#print_one_dep fmt t.Type.ty_name)
+        l
+
+    method generate_types types =
+      try
+        let oc = open_out !Args.out_file in
+        let fmt = F.formatter_of_out_channel oc in
+        F.fprintf fmt "%s" self#header;
+        let graph = Odoc_info.Dep.deps_of_types 
+            ~kernel: !Args.dot_reduce
+            types 
+        in
+        List.iter (self#generate_for_type fmt) graph;
+        F.fprintf fmt "}\n" ;
+        F.pp_print_flush fmt ();
+        close_out oc
+      with
+        Sys_error s ->
+          raise (Failure s)
+
+    method generate_modules modules_list = 
+      try
+        modules <- modules_list ;
+        let oc = open_out !Args.out_file in
+        let fmt = F.formatter_of_out_channel oc in
+        F.fprintf fmt "%s" self#header;
+
+        if !Args.dot_reduce then 
+          Odoc_info.Dep.kernel_deps_of_modules modules_list;
+
+        List.iter (self#generate_for_module fmt) modules_list;
+        F.fprintf fmt "}\n" ;
+        F.pp_print_flush fmt ();
+        close_out oc
+      with
+        Sys_error s ->
+          raise (Failure s)
+
+    (** Generate the dot code in the file {!Odoc_info.Args.out_file}. *)
+    method generate (modules_list : Odoc_info.Module.t_module list) =
+      if !Args.dot_types then
+        self#generate_types (Odoc_info.Search.types modules_list)
+      else
+        self#generate_modules modules_list
+  end