ocaml/ocamldoc/odoc_dot.ml

148 lines
4.6 KiB
OCaml
Raw Normal View History

(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* 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 GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(** Definition of a class which outputs a dot file showing
top modules dependencies.*)
open Odoc_info
module F = Format
let dot_include_all = ref false
let dot_types = ref false
let dot_reduce = ref false
let dot_colors = ref (List.flatten Odoc_messages.default_dot_colors)
module Generator =
struct
(** 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 = !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 ->
!dot_include_all ||
(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 !Global.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: !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 !Global.out_file in
let fmt = F.formatter_of_out_channel oc in
F.fprintf fmt "%s" self#header;
if !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) =
colors <- !dot_colors;
if !dot_types then
self#generate_types (Odoc_info.Search.types modules_list)
else
self#generate_modules modules_list
end
end
module type Dot_generator = module type of Generator