File: odoc_dot.ml

package info (click to toggle)
ocaml 4.05.0-11
  • links: PTS, VCS
  • area: main
  • in suites:
  • size: 27,060 kB
  • sloc: ml: 199,255; ansic: 44,187; sh: 5,611; makefile: 4,958; lisp: 4,223; asm: 4,220; awk: 306; perl: 87; fortran: 21; cs: 9; sed: 9
file content (147 lines) | stat: -rw-r--r-- 4,751 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
(**************************************************************************)
(*                                                                        *)
(*                                 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