-
Notifications
You must be signed in to change notification settings - Fork 293
/
Viz.pm
75 lines (62 loc) · 1.98 KB
/
Viz.pm
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
use v6;
use Perl6::TypeGraph;
class Perl6::TypeGraph::Viz {
has @.types;
has $.dot-hints;
has $.url-base = '../type/';
has $.rank-dir = 'BT';
has $.role-color = '#6666FF';
has $.class-color = '#000000';
method new-for-type ($type) {
my $self = self.bless(*, :types([$type]));
$self!add-neighbors;
return $self;
}
method !add-neighbors {
sub visit ($n) {
state %seen;
return if %seen{$n}++;
visit($_) for $n.super, $n.roles;
@!types.push: $n;
}
for @.types -> $t {
visit($_) for $t, $t.sub, $t.doers;
}
@.types .= uniq;
}
method as-dot () {
my @dot;
@dot.push: "digraph \"perl6-type-graph\" \{\n rankdir=$.rank-dir;\n splines=polyline;\n";
if $.dot-hints {
@dot.push: "\n // Layout hints\n";
@dot.push: $.dot-hints;
}
@dot.push: "\n // Types\n";
for @.types -> $type {
my $color = $type.packagetype eq 'role' ?? $.role-color !! $.class-color;
@dot.push: " \"$type.name()\" [color=\"$color\", fontcolor=\"$color\", href=\"{$.url-base ~ $type.name ~ '.html' }\"];\n";
}
@dot.push: "\n // Superclasses\n";
for @.types -> $type {
for $type.super -> $super {
@dot.push: " \"$type.name()\" -> \"$super\" [color=\"$.class-color\"];\n";
}
}
@dot.push: "\n // Roles\n";
for @.types -> $type {
for $type.roles -> $role {
@dot.push: " \"$type.name()\" -> \"$role\" [color=\"$.role-color\"];\n";
}
}
@dot.push: "\}\n";
return @dot.join;
}
method to-dot-file ($file) {
spurt $file, self.as-dot;
}
method to-file ($file, :$format = 'svg') {
my $pipe = open "dot -T$format -o$file", :w, :p;
$pipe.print: self.as-dot;
close $pipe;
}
}