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