Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 576 lines (509 sloc) 18.798 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
513a9df @Aqua-Ye [doc] tools: changed files headers to MIT license
Aqua-Ye authored
4 This file is part of Opa.
fccc685 Initial open-source release
MLstate authored
5
513a9df @Aqua-Ye [doc] tools: changed files headers to MIT license
Aqua-Ye authored
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:
fccc685 Initial open-source release
MLstate authored
7
513a9df @Aqua-Ye [doc] tools: changed files headers to MIT license
Aqua-Ye authored
8 The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
fccc685 Initial open-source release
MLstate authored
9
513a9df @Aqua-Ye [doc] tools: changed files headers to MIT license
Aqua-Ye authored
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.
fccc685 Initial open-source release
MLstate authored
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
684229e @hbbio [fix] compilation for ocamlgraph 1.8.5 or newer
hbbio authored
103 | _libroot,subpath -> Some { Graph.Graphviz.DotAttributes. sg_name = subpath; sg_attributes = [ `Label subpath ]; sg_parent = None }
fccc685 Initial open-source release
MLstate authored
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 ];
684229e @hbbio [fix] compilation for ocamlgraph 1.8.5 or newer
hbbio authored
138 Graph.Graphviz.DotAttributes.sg_parent = None;
fccc685 Initial open-source release
MLstate authored
139 })
140 l.Lib.repo
141 let default_edge_attributes _t = []
142 let edge_attributes _e = []
143 end
144
145 module GLDot = Graph.Graphviz.Dot(LibDot)
146
147 (**
148 Transforming the information into graphs
149 *)
150 type graphs = {
151 g_libs : (lib_name, GM.t) Hashtbl.t ;
152 global : GL.t ;
153 }
154
155 let create () =
156 let g_libs = Hashtbl.create 10 in
157 let global = GL.create () in
158 {
159 g_libs = g_libs ;
160 global = global ;
161 }
162
163 (* create or get graphs for a lib *)
164 let getlib g lib =
165 try
166 Hashtbl.find g.g_libs lib.Lib.lib
167 with
168 | Not_found ->
169 let lg = GM.create () in
170 Hashtbl.add g.g_libs lib.Lib.lib lg;
171 lg
172
173 let compute env =
174 let graphs = create () in
175
176 (* vertices *)
177 let _ = LibMap.iter (
178 fun lib set ->
179 if not lib.Lib.sublib then GL.add_vertex graphs.global lib ;
180 let g = getlib graphs lib in
181 ModuleSet.iter (fun m -> GM.add_vertex g m) set ;
182 ()
183 ) env.libs in
184
185 (* edges *)
186 (*
187 module_ depends on depend,
188 add corresponding edges to the graphs
189 *)
190 let rec iter_dep module_ depend =
191 let lib1 = module_.Module.lib in
192 let lib2 = depend.Module.lib in
193 if lib1 = lib2
194 then (
195 let g = getlib graphs lib1 in
196 match module_.Module.sublib, depend.Module.sublib with
197 | Some sub1, Some sub2 ->
198 if sub1 = sub2
199 then
200 (* internal dependency *)
201 GM.add_edge g depend module_
202 else
203 (* internal dependency betwen submod *)
204 GM.add_edge g sub2 sub1
205 | Some module_, None ->
206 GM.add_edge g depend module_
207 | None, Some depend ->
208 GM.add_edge g depend module_
209 | None, None ->
210 GM.add_edge g depend module_
211 )
212 else (
213 (* global dependency *)
214 match module_.Module.sublib, depend.Module.sublib with
215 | None, None ->
216 GL.add_edge graphs.global lib2 lib1
217 | Some module_, None ->
218 iter_dep module_ depend
219 | None, Some depend ->
220 iter_dep module_ depend
221 | Some module_, Some depend ->
222 iter_dep module_ depend
223 )
224 in
225
226 let iter module_ set =
227 let iter depend = iter_dep module_ depend in
228 ModuleSet.iter iter set
229 in
230 let () = ModuleMap.iter iter env.depends in
231 graphs
232
233 let handle_open_out file =
234 Printf.printf "generating graph %S\n%!" file ;
235 try open_out file
236 with
237 | Sys_error s ->
238 error "<!> cannot open_out %S : %s" file s
239
240 let handle_close_out file oc =
241 try close_out oc
242 with
243 | Sys_error s ->
244 error "<!> cannot close_out %S : %s" file s
245
246 let global = "odep__all.dot"
247 let lib name = Printf.sprintf "odep__lib_%s.dot" name
248 let output ?(output_dir="") graphs =
249 let success = File.check_create_path output_dir in
250 if not success then error "<!> cannot create directory %S" output_dir;
251 let path s = Filename.concat output_dir s in
252 let global = path global in
253 let oc = handle_open_out global in
254 GLDot.output_graph oc graphs.global ;
255 handle_close_out global oc ;
256 let iter libname graph =
257 let filename = path (lib libname) in
258 let oc = handle_open_out filename in
259 GMDot.output_graph oc graph ;
260 handle_close_out filename oc ;
261 in
262 Hashtbl.iter iter graphs.g_libs
263 end
264
265 module Trim =
266 struct
267 let parse line =
268 let line =
269 match String.findi '#' line with
270 | None -> line
271 | Some i -> String.sub line 0 i
272 in
273 let line = String.trim line in
274 let length = String.length line in
275 if length = 0
276 then None
277 else Some line
278 end
279
280 let debug = ref None
281 let log level fmt =
282 let f = Format.std_formatter in
283 match !debug with
284 | Some i when i = level ->
285 Format.fprintf f fmt
286 | _ ->
287 Format.ifprintf f fmt
288
289 let lines_foldi fold acc filename =
290 if not (File.is_regular filename)
291 then (
292 Printf.eprintf "<!> file %S not found (ignored)\n%!" filename ;
293 acc
294 )
295 else File.lines_foldi fold acc filename
296
297 module Mllib =
298 struct
299 let parse line =
300 let line = Trim.parse line in
301 match line with
302 | None -> None
303 | Some line ->
304 let path = Filename.dirname line in
305 let module_name = Filename.basename line in
306 Some (path, module_name)
307
308 let fold env filename =
309 (* the name of the lib, is the basename without extension *)
310 let libname = File.chop_extension (Filename.basename filename) in
311 let repo =
312 match
461365b [cleanup] Base.String: changed String.split to a much simpler String.…
Louis Gesbert authored
313 try String.slice '/' (Unix.readlink filename)
fccc685 Initial open-source release
MLstate authored
314 with Unix.Unix_error _ -> []
315 with
316 | "repos"::repo::_ -> Some repo
317 | _ -> None in
318 let fold env line i =
319 match parse line with
320 | None -> env
321 | Some (path, module_name) ->
461365b [cleanup] Base.String: changed String.split to a much simpler String.…
Louis Gesbert authored
322 let path_elts = String.slice '/' path in
fccc685 Initial open-source release
MLstate authored
323 match path_elts with
324 | [] ->
325 Printf.eprintf (
326 "<!> file %S, line %d\n"^^
327 " module %s with empty path ignored\n%!"
328 )
329 filename i module_name
330 ;
331 env
332 | [path] ->
333 let lib = { Lib.lib = libname ; sublib = false ; repo = repo } in
334 let module_ = { Module.
335 lib = lib ;
336 name = module_name ;
337 path = path ;
338 sublib = None ;
339 } in
340 let _ =
341 log 10 (
342 "mllib:%S, line %d\n"^^
343 "--> lib %S - module %S - path %S\n%!"
344 )
345 filename i
346 libname module_name path
347 in
348 let set = Option.default ModuleSet.empty (LibMap.find_opt lib env.libs) in
349 let set = ModuleSet.add module_ set in
350 let libs = LibMap.add lib set env.libs in
351 let pathmap = Option.default PathMap.empty (StringMap.find_opt module_name env.modules) in
352 let pathmap = PathMap.add path module_ pathmap in
353 let modules = StringMap.add module_name pathmap env.modules in
354 { env with libs = libs ; modules = modules }
355 | _ :: subpath -> (
356 (* we create 2 modules in this case, one for the module, and one for the sub-lib *)
357 let lib = { Lib.lib = libname ; sublib = false ; repo = repo } in
358 let submod_name = if !flat_libs then module_name else String.concat "." subpath in
359 let submod = { Module.
360 lib = lib ;
361 name = submod_name ;
362 path = path ;
363 sublib = None ;
364 } in
365
366 let libs = env.libs in
367
368 let set = Option.default ModuleSet.empty (LibMap.find_opt lib libs) in
369 let set = ModuleSet.add submod set in
370 let libs = LibMap.add lib set libs in
371
372 let modules = env.modules in
373
374 let pathmap = Option.default PathMap.empty (StringMap.find_opt submod_name modules) in
375 let pathmap = PathMap.add path submod pathmap in
376 let modules = StringMap.add submod_name pathmap modules in
377
378 let libs, modules =
379 if !flat_libs then libs, modules else
380 let sublib_name = String.concat "." path_elts in
381 let sublib = { Lib.lib = sublib_name ; sublib = true ; repo = repo } in
382 let module_ = { Module.
383 lib = sublib ;
384 name = module_name ;
385 path = path ;
386 sublib = Some submod ;
387 } in
388
389 let set = Option.default ModuleSet.empty (LibMap.find_opt sublib libs) in
390 let set = ModuleSet.add module_ set in
391 let libs = LibMap.add sublib set libs in
392
393 let pathmap = Option.default PathMap.empty (StringMap.find_opt module_name modules) in
394 let pathmap = PathMap.add path module_ pathmap in
395 let modules = StringMap.add module_name pathmap modules in
396
397 libs, modules
398 in
399
400 { env with libs = libs ; modules = modules }
401 )
402 in
403 lines_foldi fold env filename
404 end
405
406 module Depends =
407 struct
408 let parse line =
409 match Trim.parse line with
410 | None -> None
411 | Some line -> (
412 let left, right = String.split_char ':' line in
413 let left = String.trim left in
461365b [cleanup] Base.String: changed String.split to a much simpler String.…
Louis Gesbert authored
414 let depends = String.slice_chars " \t\r\n" right in
fccc685 Initial open-source release
MLstate authored
415 match Mllib.parse left with
416 | None -> None
417 | Some (path, module_name) ->
418 let module_name = File.chop_extension module_name in
419 let module_name = String.capitalize module_name in
420 Some ((path, module_name), depends)
421 )
422
423 let fold env filename =
424 let fold env line i =
425 match parse line with
426 | None -> env
427 | Some ((path, module_name), depends) -> (
428 match StringMap.find_opt module_name env.modules with
429 | None -> env
430 | Some pathmap -> (
431 match PathMap.find_opt path pathmap with
432 | Some ( module_ as parent ) ->
433 let set = Option.default ModuleSet.empty (ModuleMap.find_opt module_ env.depends) in
434 let set =
435 let fold_depends set module_name =
436 match StringMap.find_opt module_name env.modules with
437 | Some pathmap -> (
438 let ambigous = PathMap.elts pathmap in
439 match ambigous with
440 | [] ->
441 Printf.eprintf (
442 "<!> file %S, line %d\n"^^
443 "module %s has no declared path (internal error)\n"^^
444 " the dependencies defined in this line will be ignored\n%!"
445 )
446 filename i module_name
447 ;
448 set
449 | [ module_ ] ->
450 let _ =
451 log 20 (
452 "depends:%S, line %d\n"^^
453 "--> module %s depends on %s/%s\n%!"
454 )
455 filename i parent.Module.name module_.Module.path module_.Module.name
456 in
457 ModuleSet.add module_ set
458 | _ ->
459 Printf.eprintf (
460 "<!> file %S, line %d\n"^^
461 " the reference to module %s is ambigous\n"^^
462 " this module name can refer to:\n"
463 )
464 filename i module_name
465 ;
466 List.iter (
467 fun module_ ->
468 Printf.eprintf (
469 " + %s/%s from lib %s\n%!"
470 )
471 module_.Module.path module_.Module.name
472 module_.Module.lib.Lib.lib
473 ) ambigous
474 ;
475 Printf.eprintf (
476 " the dependencies defined in this line will be ignored\n%!"
477 )
478 ;
479 set
480 )
481 | None ->
482 let _ =
483 log 21 (
484 "depends:%S, line %d\n"^^
485 "--> unbound module %s\n%!"
486 )
487 filename i module_name
488 in
489 set
490 in
491 List.fold_left fold_depends set depends
492 in
493 let depends = ModuleMap.add module_ set env.depends in
494 { env with depends = depends }
495 | None ->
496 Printf.eprintf (
497 "<!> file %S, line %d\n"^^
498 " the module %s with path %S is not defined in any mllib\n"^^
499 " the dependencies defined in this line will be ignored\n%!"
500 )
501 filename i module_name path
502 ;
503 env
504 )
505 )
506 in
507 lines_foldi fold env filename
508 end
509
510 (* d *)
511
512 let depends = ref []
513
514 (* m *)
515
516 let mllib = ref []
517
518 (* o *)
519
520 let output_dir = ref ""
521
522 let spec = [
523
524 (* c *)
525
526 "--clustered",
527 Arg.Set clustered,
528 " Group libraries by repository in the graph"
529 ;
530
531 (* d *)
532
533 "--debug",
534 Arg.Int (fun i -> debug := Some i),
535 " Activate some debug logs (take a level as arg)"
536 ;
537
538 "--dir",
539 Arg.Set_string output_dir,
540 " Specify an output directory, default is ."
541 ;
542
543 (* f *)
544
545 "--flat-libs",
546 Arg.Set flat_libs,
547 " Show sub-directories as clusters within the graph of the parent lib"
548 ;
549
550 ]
551
9a4a8ee [enhance] help/manpages: global pass for improving help messages of O…
Mathieu Baudet authored
552 let usage_msg = Printf.sprintf "%s: graphs generator for ocaml dependencies\nUsage: %s *.mllib *.depends\n" Sys.argv.(0) Sys.argv.(0)
fccc685 Initial open-source release
MLstate authored
553
554 let anon_fun file =
555 match File.extension file with
556 | "depends" ->
557 depends := file :: !depends
558 | "mllib" ->
559 mllib := file :: !mllib
560 | _ ->
561 Printf.eprintf "I don't know what to do with arg %S\n%s%!" file usage_msg ;
562 exit 1
563
564 let parse () =
9a4a8ee [enhance] help/manpages: global pass for improving help messages of O…
Mathieu Baudet authored
565 Arg.parse spec anon_fun (usage_msg^"Options:")
fccc685 Initial open-source release
MLstate authored
566
567 let _ =
568 parse ();
569 let env = empty in
570 let env = List.fold_left Mllib.fold env !mllib in
571 let env = List.fold_left Depends.fold env !depends in
572 let graphs = Graphs.compute env in
573 let output_dir = !output_dir in
574 let () = Graphs.output ~output_dir graphs in
575 ()
Something went wrong with that request. Please try again.