#!/usr/bin/env perl
# usage: util/importgraph.pl [--layout=neato]
# produces importgraph.ps in the current directory
# it expects to run from the top pugs directory with src present
# arrows point from importer to importee
use strict;
use warnings;
use File::Find;
use GraphViz;
use Getopt::Long;
my $layout = "neato";
my $overlap = "false";
my @ignore;
GetOptions(
"layout=s" => \$layout,
"overlap=s" => \$overlap,
"ignore=s" => \@ignore,
) or die "invalid command line";
my $g = GraphViz->new(
layout => $layout,
directed => 1,
rankdir => 1,
overlap => $overlap,
);
my %modules;
find sub {
return unless /\.hs$/;
my ($module_name, $exports, %imports);
open my $fh, '<', $_
or die "couldn't open $File::Find::name: $!\n";
while(<$fh>) {
if (/^module \s+ ([\w.]+) (\s* \()?/x) {
$module_name = $1;
$exports = defined $2;
} elsif (/^import \s+ (qualified \s+)? ([\w.]+) (\s* \()?/x) {
$imports{$2} = [defined($1), defined($3)];
} elsif (/^import|^module/) {
warn "Unrecognised import|module: $_";
}
}
close $fh;
unless (defined $module_name) {
warn "couldn't find a module in $File::Find::name\n";
return;
}
$modules{$module_name} = [\%imports, $exports];
}, 'src';
#delete $modules{$_} for @ignore;
for my $mod (values %modules) {
for my $ignore (@ignore) {
delete $mod->[0]->{$ignore};
}
}
# setup some predefined clusters
sub setup_mod {
my $type = shift;
my $name = shift;
my $regexp = join '|', map {
UNIVERSAL::isa($_, 'Regexp') ? $_ : "^\Q$_\E\$" } @_;
$regexp = qr/$regexp/;
for my $mod (keys %modules) {
next unless $mod =~ /$regexp/;
$modules{$mod}->[$type] = $name;
print "Adding $mod to $name\n";
}
}
sub setup_cluster { setup_mod(2, @_) }
sub setup_rank { setup_mod(3, @_) }
setup_cluster('Pugs.Rule', qr/^Pugs\.Rule\b/);
setup_cluster('Pugs.AST', qr/^Pugs\.AST\b/);
setup_cluster('IMC', qr/^IMC\b/);
setup_cluster('RRegex', qr/^RRegex\b/);
setup_cluster('Emit', qr/^Emit\b/);
setup_rank('parser', qr/^Pugs\.Parser\.\w+$/);
setup_rank('parser_program', 'Pugs.Parser.Program');
setup_rank('prim', qr/^Pugs\.Prim\.\w+$/);
setup_rank('prim_lifts', 'Pugs.Prim.Lifts');
setup_rank('embed', qr/^Pugs\.Embed\.\w+$/);
setup_rank('codegens', 'Pugs.Compile.Haskell', 'Pugs.Compile.Pugs',
qr/^Pugs\.CodeGen\.\w+$/);
my ($nodes, $edges) = (0, 0);
while (my ($name, $module) = each %modules) {
my $cluster = $module->[2];
my $rank = $module->[3];
$g->add_node($name, color => ($module->[1] ? 'green' : 'black'),
(defined $cluster ? (cluster => $cluster) : ()),
(defined $rank ? (rank => $rank) : ()),
);
$nodes++;
while(my ($k, $edge) = each %{$module->[0]}) {
next unless exists $modules{$k}; # only pugs modules
my $color = $edge->[1] ? 'green' : $edge->[0] ? "blue" : "black";
$g->add_edge($name, $k, color => $color);
$edges++;
}
}
print "$nodes nodes and $edges edges\n";
#$g->as_canon("importgraph.dot");
#$g->as_png("importgraph.png");
$g->as_ps("importgraph.ps");