Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 581 lines (514 sloc) 18.233 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (**
19 Computing dependencies graphs of the framework.
20 @author Mathieu Barbin
21 *)
22
23 (**
24 This application takes *.mllib and *.depends and generates :
25 - a global graph, showing deps between libs
26 - a local graph for each lib, showing deps between modules into the lib
27 - any local submodule is shown as a node of a local graph, with an extra
28 graph for the local subdirectory.
29 *)
30
31 (* depends *)
32 module Arg = Base.Arg
33 module Char = Base.Char
34 module String = Base.String
35
36 let error fmt =
37 Printf.kfprintf (fun _ -> exit 1) stderr (fmt^^"\n%!")
38
39 type lib_name = string
40 type repo_name = string
41 type module_name = string
42 type path = string
43
44 module Lib =
45 struct
46 type t = { lib : lib_name ; sublib : bool ; repo : repo_name option }
47 let compare t t'= Pervasives.compare t.lib t'.lib
48 let hash t = Hashtbl.hash t.lib
49 let equal t t' = compare t t' = 0
50 end
51
52 module LibMap = BaseMap.Make(Lib)
53 module LibSet = BaseSet.Make(Lib)
54
55 module Module =
56 struct
57 type t = { name : module_name ; path : path ; sublib : t option ; lib : Lib.t }
58 let compare = Pervasives.compare
59 let hash = Hashtbl.hash
60 let equal = Pervasives.(=)
61 end
62
63 module ModuleMap = BaseMap.Make(Module)
64 module ModuleSet = BaseSet.Make(Module)
65
66 module PathMap = StringMap
67
68 (**
69 Parsing everything, building a big env.
70 Mllib should be folded before depends files
71 *)
72 type env = {
73 libs : ModuleSet.t LibMap.t ;
74 modules : Module.t PathMap.t StringMap.t ;
75 depends : ModuleSet.t ModuleMap.t ;
76 }
77
78 let empty = {
79 libs = LibMap.empty ;
80 modules = StringMap.empty ;
81 depends = ModuleMap.empty ;
82 }
83
84 let clustered = ref false
85 let flat_libs = ref false
86
87 module Graphs =
88 struct
89 module GM = Graph.Imperative.Digraph.Concrete(Module)
90 module GL = Graph.Imperative.Digraph.Concrete(Lib)
91
92 module ModuleDot =
93 struct
94 include GM
95 let graph_attributes _t = [
96 `Concentrate true;
97 ]
98 let default_vertex_attributes _t = []
99 let vertex_name m = Printf.sprintf "%S" m.Module.name
100 let vertex_attributes m =
101 if !flat_libs && String.contains m.Module.path '/'
102 then [ `Style `Filled; `Fillcolor 0x9999bb ]
103 else []
104 let get_subgraph m =
105 if not (!clustered && !flat_libs) then None
106 else
107 match String.split_char '/' m.Module.path with
108 | _libroot,"" -> None
109 | _libroot,subpath -> Some { Graph.Graphviz.DotAttributes. sg_name = subpath; sg_attributes = [ `Label subpath ] }
110 let default_edge_attributes _t = []
111 let edge_attributes _e = []
112 end
113
114 module GMDot = Graph.Graphviz.Dot(ModuleDot)
115
116 module LibDot =
117 struct
118 include GL
119 let graph_attributes _t = [
120 `Concentrate true;
121 `Rankdir `LeftToRight;
122 ]
123 let default_vertex_attributes _t = []
124 let vertex_name l = Printf.sprintf "%S" l.Lib.lib
125 let vertex_attributes l =
126 (if Base.String.is_contained "old" l.Lib.lib
127 then [ `Color 0xff0000; `Fontcolor 0xff0000 ]
128 else []) @
129 let color = 0xffffff in
130 (*
131 | Some "libqml" -> 0xeeee66
132 | Some "qml2llvm" -> 0x66aaaa
133 | Some "opa" -> 0xaa66aa
134 | Some "appserver" -> 0x66aa66
135 *)
136 [`Style `Filled; `Fillcolor color]
137 let get_subgraph l =
138 if not !clustered then None
139 else
140 Option.map
141 (fun repo -> {
142 Graph.Graphviz.DotAttributes.sg_name = repo;
143 Graph.Graphviz.DotAttributes.sg_attributes = [ `Label repo ];
144 })
145 l.Lib.repo
146 let default_edge_attributes _t = []
147 let edge_attributes _e = []
148 end
149
150 module GLDot = Graph.Graphviz.Dot(LibDot)
151
152 (**
153 Transforming the information into graphs
154 *)
155 type graphs = {
156 g_libs : (lib_name, GM.t) Hashtbl.t ;
157 global : GL.t ;
158 }
159
160 let create () =
161 let g_libs = Hashtbl.create 10 in
162 let global = GL.create () in
163 {
164 g_libs = g_libs ;
165 global = global ;
166 }
167
168 (* create or get graphs for a lib *)
169 let getlib g lib =
170 try
171 Hashtbl.find g.g_libs lib.Lib.lib
172 with
173 | Not_found ->
174 let lg = GM.create () in
175 Hashtbl.add g.g_libs lib.Lib.lib lg;
176 lg
177
178 let compute env =
179 let graphs = create () in
180
181 (* vertices *)
182 let _ = LibMap.iter (
183 fun lib set ->
184 if not lib.Lib.sublib then GL.add_vertex graphs.global lib ;
185 let g = getlib graphs lib in
186 ModuleSet.iter (fun m -> GM.add_vertex g m) set ;
187 ()
188 ) env.libs in
189
190 (* edges *)
191 (*
192 module_ depends on depend,
193 add corresponding edges to the graphs
194 *)
195 let rec iter_dep module_ depend =
196 let lib1 = module_.Module.lib in
197 let lib2 = depend.Module.lib in
198 if lib1 = lib2
199 then (
200 let g = getlib graphs lib1 in
201 match module_.Module.sublib, depend.Module.sublib with
202 | Some sub1, Some sub2 ->
203 if sub1 = sub2
204 then
205 (* internal dependency *)
206 GM.add_edge g depend module_
207 else
208 (* internal dependency betwen submod *)
209 GM.add_edge g sub2 sub1
210 | Some module_, None ->
211 GM.add_edge g depend module_
212 | None, Some depend ->
213 GM.add_edge g depend module_
214 | None, None ->
215 GM.add_edge g depend module_
216 )
217 else (
218 (* global dependency *)
219 match module_.Module.sublib, depend.Module.sublib with
220 | None, None ->
221 GL.add_edge graphs.global lib2 lib1
222 | Some module_, None ->
223 iter_dep module_ depend
224 | None, Some depend ->
225 iter_dep module_ depend
226 | Some module_, Some depend ->
227 iter_dep module_ depend
228 )
229 in
230
231 let iter module_ set =
232 let iter depend = iter_dep module_ depend in
233 ModuleSet.iter iter set
234 in
235 let () = ModuleMap.iter iter env.depends in
236 graphs
237
238 let handle_open_out file =
239 Printf.printf "generating graph %S\n%!" file ;
240 try open_out file
241 with
242 | Sys_error s ->
243 error "<!> cannot open_out %S : %s" file s
244
245 let handle_close_out file oc =
246 try close_out oc
247 with
248 | Sys_error s ->
249 error "<!> cannot close_out %S : %s" file s
250
251 let global = "odep__all.dot"
252 let lib name = Printf.sprintf "odep__lib_%s.dot" name
253 let output ?(output_dir="") graphs =
254 let success = File.check_create_path output_dir in
255 if not success then error "<!> cannot create directory %S" output_dir;
256 let path s = Filename.concat output_dir s in
257 let global = path global in
258 let oc = handle_open_out global in
259 GLDot.output_graph oc graphs.global ;
260 handle_close_out global oc ;
261 let iter libname graph =
262 let filename = path (lib libname) in
263 let oc = handle_open_out filename in
264 GMDot.output_graph oc graph ;
265 handle_close_out filename oc ;
266 in
267 Hashtbl.iter iter graphs.g_libs
268 end
269
270 module Trim =
271 struct
272 let parse line =
273 let line =
274 match String.findi '#' line with
275 | None -> line
276 | Some i -> String.sub line 0 i
277 in
278 let line = String.trim line in
279 let length = String.length line in
280 if length = 0
281 then None
282 else Some line
283 end
284
285 let debug = ref None
286 let log level fmt =
287 let f = Format.std_formatter in
288 match !debug with
289 | Some i when i = level ->
290 Format.fprintf f fmt
291 | _ ->
292 Format.ifprintf f fmt
293
294 let lines_foldi fold acc filename =
295 if not (File.is_regular filename)
296 then (
297 Printf.eprintf "<!> file %S not found (ignored)\n%!" filename ;
298 acc
299 )
300 else File.lines_foldi fold acc filename
301
302 module Mllib =
303 struct
304 let parse line =
305 let line = Trim.parse line in
306 match line with
307 | None -> None
308 | Some line ->
309 let path = Filename.dirname line in
310 let module_name = Filename.basename line in
311 Some (path, module_name)
312
313 let fold env filename =
314 (* the name of the lib, is the basename without extension *)
315 let libname = File.chop_extension (Filename.basename filename) in
316 let repo =
317 match
461365b [cleanup] Base.String: changed String.split to a much simpler String.sli...
Louis Gesbert authored
318 try String.slice '/' (Unix.readlink filename)
fccc685 Initial open-source release
MLstate authored
319 with Unix.Unix_error _ -> []
320 with
321 | "repos"::repo::_ -> Some repo
322 | _ -> None in
323 let fold env line i =
324 match parse line with
325 | None -> env
326 | Some (path, module_name) ->
461365b [cleanup] Base.String: changed String.split to a much simpler String.sli...
Louis Gesbert authored
327 let path_elts = String.slice '/' path in
fccc685 Initial open-source release
MLstate authored
328 match path_elts with
329 | [] ->
330 Printf.eprintf (
331 "<!> file %S, line %d\n"^^
332 " module %s with empty path ignored\n%!"
333 )
334 filename i module_name
335 ;
336 env
337 | [path] ->
338 let lib = { Lib.lib = libname ; sublib = false ; repo = repo } in
339 let module_ = { Module.
340 lib = lib ;
341 name = module_name ;
342 path = path ;
343 sublib = None ;
344 } in
345 let _ =
346 log 10 (
347 "mllib:%S, line %d\n"^^
348 "--> lib %S - module %S - path %S\n%!"
349 )
350 filename i
351 libname module_name path
352 in
353 let set = Option.default ModuleSet.empty (LibMap.find_opt lib env.libs) in
354 let set = ModuleSet.add module_ set in
355 let libs = LibMap.add lib set env.libs in
356 let pathmap = Option.default PathMap.empty (StringMap.find_opt module_name env.modules) in
357 let pathmap = PathMap.add path module_ pathmap in
358 let modules = StringMap.add module_name pathmap env.modules in
359 { env with libs = libs ; modules = modules }
360 | _ :: subpath -> (
361 (* we create 2 modules in this case, one for the module, and one for the sub-lib *)
362 let lib = { Lib.lib = libname ; sublib = false ; repo = repo } in
363 let submod_name = if !flat_libs then module_name else String.concat "." subpath in
364 let submod = { Module.
365 lib = lib ;
366 name = submod_name ;
367 path = path ;
368 sublib = None ;
369 } in
370
371 let libs = env.libs in
372
373 let set = Option.default ModuleSet.empty (LibMap.find_opt lib libs) in
374 let set = ModuleSet.add submod set in
375 let libs = LibMap.add lib set libs in
376
377 let modules = env.modules in
378
379 let pathmap = Option.default PathMap.empty (StringMap.find_opt submod_name modules) in
380 let pathmap = PathMap.add path submod pathmap in
381 let modules = StringMap.add submod_name pathmap modules in
382
383 let libs, modules =
384 if !flat_libs then libs, modules else
385 let sublib_name = String.concat "." path_elts in
386 let sublib = { Lib.lib = sublib_name ; sublib = true ; repo = repo } in
387 let module_ = { Module.
388 lib = sublib ;
389 name = module_name ;
390 path = path ;
391 sublib = Some submod ;
392 } in
393
394 let set = Option.default ModuleSet.empty (LibMap.find_opt sublib libs) in
395 let set = ModuleSet.add module_ set in
396 let libs = LibMap.add sublib set libs in
397
398 let pathmap = Option.default PathMap.empty (StringMap.find_opt module_name modules) in
399 let pathmap = PathMap.add path module_ pathmap in
400 let modules = StringMap.add module_name pathmap modules in
401
402 libs, modules
403 in
404
405 { env with libs = libs ; modules = modules }
406 )
407 in
408 lines_foldi fold env filename
409 end
410
411 module Depends =
412 struct
413 let parse line =
414 match Trim.parse line with
415 | None -> None
416 | Some line -> (
417 let left, right = String.split_char ':' line in
418 let left = String.trim left in
461365b [cleanup] Base.String: changed String.split to a much simpler String.sli...
Louis Gesbert authored
419 let depends = String.slice_chars " \t\r\n" right in
fccc685 Initial open-source release
MLstate authored
420 match Mllib.parse left with
421 | None -> None
422 | Some (path, module_name) ->
423 let module_name = File.chop_extension module_name in
424 let module_name = String.capitalize module_name in
425 Some ((path, module_name), depends)
426 )
427
428 let fold env filename =
429 let fold env line i =
430 match parse line with
431 | None -> env
432 | Some ((path, module_name), depends) -> (
433 match StringMap.find_opt module_name env.modules with
434 | None -> env
435 | Some pathmap -> (
436 match PathMap.find_opt path pathmap with
437 | Some ( module_ as parent ) ->
438 let set = Option.default ModuleSet.empty (ModuleMap.find_opt module_ env.depends) in
439 let set =
440 let fold_depends set module_name =
441 match StringMap.find_opt module_name env.modules with
442 | Some pathmap -> (
443 let ambigous = PathMap.elts pathmap in
444 match ambigous with
445 | [] ->
446 Printf.eprintf (
447 "<!> file %S, line %d\n"^^
448 "module %s has no declared path (internal error)\n"^^
449 " the dependencies defined in this line will be ignored\n%!"
450 )
451 filename i module_name
452 ;
453 set
454 | [ module_ ] ->
455 let _ =
456 log 20 (
457 "depends:%S, line %d\n"^^
458 "--> module %s depends on %s/%s\n%!"
459 )
460 filename i parent.Module.name module_.Module.path module_.Module.name
461 in
462 ModuleSet.add module_ set
463 | _ ->
464 Printf.eprintf (
465 "<!> file %S, line %d\n"^^
466 " the reference to module %s is ambigous\n"^^
467 " this module name can refer to:\n"
468 )
469 filename i module_name
470 ;
471 List.iter (
472 fun module_ ->
473 Printf.eprintf (
474 " + %s/%s from lib %s\n%!"
475 )
476 module_.Module.path module_.Module.name
477 module_.Module.lib.Lib.lib
478 ) ambigous
479 ;
480 Printf.eprintf (
481 " the dependencies defined in this line will be ignored\n%!"
482 )
483 ;
484 set
485 )
486 | None ->
487 let _ =
488 log 21 (
489 "depends:%S, line %d\n"^^
490 "--> unbound module %s\n%!"
491 )
492 filename i module_name
493 in
494 set
495 in
496 List.fold_left fold_depends set depends
497 in
498 let depends = ModuleMap.add module_ set env.depends in
499 { env with depends = depends }
500 | None ->
501 Printf.eprintf (
502 "<!> file %S, line %d\n"^^
503 " the module %s with path %S is not defined in any mllib\n"^^
504 " the dependencies defined in this line will be ignored\n%!"
505 )
506 filename i module_name path
507 ;
508 env
509 )
510 )
511 in
512 lines_foldi fold env filename
513 end
514
515 (* d *)
516
517 let depends = ref []
518
519 (* m *)
520
521 let mllib = ref []
522
523 (* o *)
524
525 let output_dir = ref ""
526
527 let spec = [
528
529 (* c *)
530
531 "--clustered",
532 Arg.Set clustered,
533 " Group libraries by repository in the graph"
534 ;
535
536 (* d *)
537
538 "--debug",
539 Arg.Int (fun i -> debug := Some i),
540 " Activate some debug logs (take a level as arg)"
541 ;
542
543 "--dir",
544 Arg.Set_string output_dir,
545 " Specify an output directory, default is ."
546 ;
547
548 (* f *)
549
550 "--flat-libs",
551 Arg.Set flat_libs,
552 " Show sub-directories as clusters within the graph of the parent lib"
553 ;
554
555 ]
556
557 let usage_msg = Printf.sprintf "bld ocaml dependencies graphs generator\nuse: %s *.mllib *.depends\n" Sys.argv.(0)
558
559 let anon_fun file =
560 match File.extension file with
561 | "depends" ->
562 depends := file :: !depends
563 | "mllib" ->
564 mllib := file :: !mllib
565 | _ ->
566 Printf.eprintf "I don't know what to do with arg %S\n%s%!" file usage_msg ;
567 exit 1
568
569 let parse () =
570 Arg.parse spec anon_fun usage_msg
571
572 let _ =
573 parse ();
574 let env = empty in
575 let env = List.fold_left Mllib.fold env !mllib in
576 let env = List.fold_left Depends.fold env !depends in
577 let graphs = Graphs.compute env in
578 let output_dir = !output_dir in
579 let () = Graphs.output ~output_dir graphs in
580 ()
Something went wrong with that request. Please try again.