1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 2001 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 (** Top modules dependencies. *)
17
18 module Module = Odoc_module
19 module Type = Odoc_type
20 module String = Misc.Stdlib.String
21
22 let set_to_list s =
23 let l = ref [] in
24 String.Set.iter (fun e -> l := e :: !l) s;
25 !l
26
27 let impl_dependencies ast =
28 Depend.free_structure_names := String.Set.empty;
29 Depend.add_use_file String.Map.empty [Parsetree.Ptop_def ast];
30 set_to_list !Depend.free_structure_names
31
32 let intf_dependencies ast =
33 Depend.free_structure_names := String.Set.empty;
34 Depend.add_signature String.Map.empty ast;
35 set_to_list !Depend.free_structure_names
36
37
38 module Dep =
39 struct
40 type id = string
41
42 let set_to_list s =
43 let l = ref [] in
44 String.Set.iter (fun e -> l := e :: !l) s;
45 !l
46
47 type node = {
48 id : id ;
49 mutable near : String.Set.t ; (** direct children *)
50 mutable far : (id * String.Set.t) list ; (** indirect children, from which children path *)
51 reflex : bool ; (** reflexive or not, we keep
52 information here to remove the node itself from its direct children *)
53 }
54
55 type graph = node list
56
57 let make_node s children =
58 let set = List.fold_right
59 String.Set.add
60 children
61 String.Set.empty
62 in
63 { id = s;
64 near = String.Set.remove s set ;
65 far = [] ;
66 reflex = List.mem s children ;
67 }
68
69 let get_node graph s =
70 try List.find (fun n -> n.id = s) graph
71 with Not_found ->
72 make_node s []
73
74 let rec trans_closure graph acc n =
75 if String.Set.mem n.id acc then
76 acc
77 else
78 (* potential optimisation: use far field if nonempty? *)
79 String.Set.fold
80 (fun child -> fun acc2 ->
81 trans_closure graph acc2 (get_node graph child))
82 n.near
83 (String.Set.add n.id acc)
84
85 let node_trans_closure graph n =
86 let far = List.map
87 (fun child ->
88 let set = trans_closure graph String.Set.empty (get_node graph child) in
89 (child, set)
90 )
91 (set_to_list n.near)
92 in
93 n.far <- far
94
95 let compute_trans_closure graph =
96 List.iter (node_trans_closure graph) graph
97
98 let prune_node graph node =
99 String.Set.iter
100 (fun child ->
101 let set_reachables = List.fold_left
102 (fun acc -> fun (ch, reachables) ->
103 if child = ch then
104 acc
105 else
106 String.Set.union acc reachables
107 )
108 String.Set.empty
109 node.far
110 in
111 let set = String.Set.remove node.id set_reachables in
112 if String.Set.exists (fun n2 -> String.Set.mem child (get_node graph n2).near) set then
113 (
114 node.near <- String.Set.remove child node.near ;
115 node.far <- List.filter (fun (ch,_) -> ch <> child) node.far
116 )
117 else
118 ()
119 )
120 node.near;
121 if node.reflex then
122 node.near <- String.Set.add node.id node.near
123 else
124 ()
125
126 let kernel graph =
127 (* compute transitive closure *)
128 compute_trans_closure graph ;
129
130 (* remove edges to keep a transitive kernel *)
131 List.iter (prune_node graph) graph;
132
133 graph
134
135 end
136
137 (** [type_deps t] returns the list of fully qualified type names
138 [t] depends on. *)
139 let type_deps t =
140 let module T = Odoc_type in
141 let l = ref [] in
142 let re = Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)" in
143 let f s =
144 let s2 = Str.matched_string s in
145 l := s2 :: !l ;
146 s2
147 in
148 let ty t =
149 let s = Odoc_print.string_of_type_expr t in
150 ignore (Str.global_substitute re f s)
151 in
152 (match t.T.ty_kind with
153 T.Type_abstract -> ()
154 | T.Type_variant cl ->
155 List.iter
156 (fun c ->
157 match c.T.vc_args with
158 | T.Cstr_tuple l -> List.iter ty l
159 | T.Cstr_record l -> List.iter (fun r -> ty r.T.rf_type) l
160 )
161 cl
162 | T.Type_record rl ->
163 List.iter (fun r -> ty r.T.rf_type) rl
164 | T.Type_open -> ()
165 );
166
167 (match t.T.ty_manifest with
168 None -> ()
169 | Some (T.Object_type fields) ->
170 List.iter (fun r -> ty r.T.of_type) fields
171 | Some (T.Other e) ->
172 ty e
173 );
174
175 !l
176
177 (** Modify the module dependencies of the given list of modules,
178 to get the minimum transitivity kernel. *)
179 let kernel_deps_of_modules modules =
180 let graph = List.map
181 (fun m -> Dep.make_node m.Module.m_name m.Module.m_top_deps)
182 modules
183 in
184 let k = Dep.kernel graph in
185 List.iter
186 (fun m ->
187 let node = Dep.get_node k m.Module.m_name in
188 m.Module.m_top_deps <-
189 List.filter (fun m2 -> String.Set.mem m2 node.Dep.near) m.Module.m_top_deps)
190 modules
191
192 (** Return the list of dependencies between the given types,
193 in the form of a list [(type, names of types it depends on)].
194 @param kernel indicates if we must keep only the transitivity kernel
195 of the dependencies. Default is [false].
196 *)
197 let deps_of_types ?(kernel=false) types =
198 let deps_pre = List.map (fun t -> (t, type_deps t)) types in
199 if kernel then
200 (
201 let graph = List.map
202 (fun (t, names) -> Dep.make_node t.Type.ty_name names)
203 deps_pre
204 in
205 let k = Dep.kernel graph in
206 List.map
207 (fun t ->
208 let node = Dep.get_node k t.Type.ty_name in
209 (t, Dep.set_to_list node.Dep.near)
210 )
211 types
212 )
213 else
214 deps_pre
215