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
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
|
(**************************************************************************)
(* *)
(* 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. *)
(* *)
(**************************************************************************)
(** Top modules dependencies. *)
module StrS = Depend.StringSet
module StrM = Depend.StringMap
module Module = Odoc_module
module Type = Odoc_type
let set_to_list s =
let l = ref [] in
StrS.iter (fun e -> l := e :: !l) s;
!l
let impl_dependencies ast =
Depend.free_structure_names := StrS.empty;
Depend.add_use_file StrM.empty [Parsetree.Ptop_def ast];
set_to_list !Depend.free_structure_names
let intf_dependencies ast =
Depend.free_structure_names := StrS.empty;
Depend.add_signature StrM.empty ast;
set_to_list !Depend.free_structure_names
module Dep =
struct
type id = string
module S = Set.Make (struct
type t = string
let compare (x:t) y = compare x y
end)
let set_to_list s =
let l = ref [] in
S.iter (fun e -> l := e :: !l) s;
!l
type node = {
id : id ;
mutable near : S.t ; (** direct children *)
mutable far : (id * S.t) list ; (** indirect children, from which children path *)
reflex : bool ; (** reflexive or not, we keep
information here to remove the node itself from its direct children *)
}
type graph = node list
let make_node s children =
let set = List.fold_right
S.add
children
S.empty
in
{ id = s;
near = S.remove s set ;
far = [] ;
reflex = List.mem s children ;
}
let get_node graph s =
try List.find (fun n -> n.id = s) graph
with Not_found ->
make_node s []
let rec trans_closure graph acc n =
if S.mem n.id acc then
acc
else
(* potential optimisation: use far field if nonempty? *)
S.fold
(fun child -> fun acc2 ->
trans_closure graph acc2 (get_node graph child))
n.near
(S.add n.id acc)
let node_trans_closure graph n =
let far = List.map
(fun child ->
let set = trans_closure graph S.empty (get_node graph child) in
(child, set)
)
(set_to_list n.near)
in
n.far <- far
let compute_trans_closure graph =
List.iter (node_trans_closure graph) graph
let prune_node graph node =
S.iter
(fun child ->
let set_reachables = List.fold_left
(fun acc -> fun (ch, reachables) ->
if child = ch then
acc
else
S.union acc reachables
)
S.empty
node.far
in
let set = S.remove node.id set_reachables in
if S.exists (fun n2 -> S.mem child (get_node graph n2).near) set then
(
node.near <- S.remove child node.near ;
node.far <- List.filter (fun (ch,_) -> ch <> child) node.far
)
else
()
)
node.near;
if node.reflex then
node.near <- S.add node.id node.near
else
()
let kernel graph =
(* compute transitive closure *)
compute_trans_closure graph ;
(* remove edges to keep a transitive kernel *)
List.iter (prune_node graph) graph;
graph
end
(** [type_deps t] returns the list of fully qualified type names
[t] depends on. *)
let type_deps t =
let module T = Odoc_type in
let l = ref [] in
let re = Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)" in
let f s =
let s2 = Str.matched_string s in
l := s2 :: !l ;
s2
in
let ty t =
let s = Odoc_print.string_of_type_expr t in
ignore (Str.global_substitute re f s)
in
(match t.T.ty_kind with
T.Type_abstract -> ()
| T.Type_variant cl ->
List.iter
(fun c ->
match c.T.vc_args with
| T.Cstr_tuple l -> List.iter ty l
| T.Cstr_record l -> List.iter (fun r -> ty r.T.rf_type) l
)
cl
| T.Type_record rl ->
List.iter (fun r -> ty r.T.rf_type) rl
| T.Type_open -> ()
);
(match t.T.ty_manifest with
None -> ()
| Some (T.Object_type fields) ->
List.iter (fun r -> ty r.T.of_type) fields
| Some (T.Other e) ->
ty e
);
!l
(** Modify the modules depencies of the given list of modules,
to get the minimum transitivity kernel. *)
let kernel_deps_of_modules modules =
let graph = List.map
(fun m -> Dep.make_node m.Module.m_name m.Module.m_top_deps)
modules
in
let k = Dep.kernel graph in
List.iter
(fun m ->
let node = Dep.get_node k m.Module.m_name in
m.Module.m_top_deps <-
List.filter (fun m2 -> Dep.S.mem m2 node.Dep.near) m.Module.m_top_deps)
modules
(** Return the list of dependencies between the given types,
in the form of a list [(type, names of types it depends on)].
@param kernel indicates if we must keep only the transitivity kernel
of the dependencies. Default is [false].
*)
let deps_of_types ?(kernel=false) types =
let deps_pre = List.map (fun t -> (t, type_deps t)) types in
if kernel then
(
let graph = List.map
(fun (t, names) -> Dep.make_node t.Type.ty_name names)
deps_pre
in
let k = Dep.kernel graph in
List.map
(fun t ->
let node = Dep.get_node k t.Type.ty_name in
(t, Dep.set_to_list node.Dep.near)
)
types
)
else
deps_pre
|
