util/importgraph.pl

   1 #!/usr/bin/env perl
   2 # usage: util/importgraph.pl [--layout=neato]
   3 # produces importgraph.ps in the current directory
   4 # it expects to run from the top pugs directory with src present
   5 # arrows point from importer to importee
   6
   7 use strict;
   8 use warnings;
   9 use File::Find;
  10 use GraphViz;
  11 use Getopt::Long;
  12
  13 my $layout = "neato";
  14 my $overlap = "false";
  15 my @ignore;
  16 GetOptions(
  17   "layout=s" => \$layout,
  18   "overlap=s" => \$overlap,
  19   "ignore=s" => \@ignore,
  20 ) or die "invalid command line";
  21
  22 my $g = GraphViz->new(
  23   layout => $layout,
  24   directed => 1,
  25   rankdir => 1,
  26   overlap => $overlap,
  27 );
  28
  29 my %modules;
  30 find sub {
  31   return unless /\.hs$/;
  32
  33   my ($module_name, $exports, %imports);
  34
  35   open my $fh, '<', $_
  36     or die "couldn't open $File::Find::name: $!\n";
  37
  38   while(<$fh>) {
  39     if (/^module \s+ ([\w.]+) (\s* \()?/x) {
  40       $module_name = $1;
  41       $exports = defined $2;
  42     } elsif (/^import \s+ (qualified \s+)? ([\w.]+) (\s* \()?/x) {
  43       $imports{$2} = [defined($1), defined($3)];
  44     } elsif (/^import|^module/) {
  45       warn "Unrecognised import|module: $_";
  46     }
  47   }
  48
  49   close $fh;
  50
  51   unless (defined $module_name) {
  52     warn "couldn't find a module in $File::Find::name\n";
  53     return;
  54   }
  55
  56   $modules{$module_name} = [\%imports, $exports];
  57 }, 'src';
  58
  59 #delete $modules{$_} for @ignore;
  60 for my $mod (values %modules) {
  61   for my $ignore (@ignore) {
  62     delete $mod->[0]->{$ignore};
  63   }
  64 }
  65
  66 # setup some predefined clusters
  67 sub setup_mod {
  68   my $type = shift;
  69   my $name = shift;
  70   my $regexp = join '|', map {
  71     UNIVERSAL::isa($_, 'Regexp') ? $_ : "^\Q$_\E\$" } @_;
  72   $regexp = qr/$regexp/;
  73   for my $mod (keys %modules) {
  74     next unless $mod =~ /$regexp/;
  75     $modules{$mod}->[$type] = $name;
  76     print "Adding $mod to $name\n";
  77   }
  78 }
  79 sub setup_cluster { setup_mod(2, @_) }
  80 sub setup_rank { setup_mod(3, @_) }
  81
  82 setup_cluster('Pugs.Rule', qr/^Pugs\.Rule\b/);
  83 setup_cluster('Pugs.AST', qr/^Pugs\.AST\b/);
  84 setup_cluster('IMC', qr/^IMC\b/);
  85 setup_cluster('RRegex', qr/^RRegex\b/);
  86 setup_cluster('Emit', qr/^Emit\b/);
  87 setup_rank('parser', qr/^Pugs\.Parser\.\w+$/);
  88 setup_rank('parser_program', 'Pugs.Parser.Program');
  89 setup_rank('prim', qr/^Pugs\.Prim\.\w+$/);
  90 setup_rank('prim_lifts', 'Pugs.Prim.Lifts');
  91 setup_rank('embed', qr/^Pugs\.Embed\.\w+$/);
  92 setup_rank('codegens', 'Pugs.Compile.Haskell', 'Pugs.Compile.Pugs',
  93   qr/^Pugs\.CodeGen\.\w+$/);
  94
  95 my ($nodes, $edges) = (0, 0);
  96 while (my ($name, $module) = each %modules) {
  97   my $cluster = $module->[2];
  98   my $rank = $module->[3];
  99   $g->add_node($name, color => ($module->[1] ? 'green' : 'black'),
 100     (defined $cluster ? (cluster => $cluster) : ()),
 101     (defined $rank ? (rank => $rank) : ()),
 102     );
 103   $nodes++;
 104
 105   while(my ($k, $edge) = each %{$module->[0]}) {
 106     next unless exists $modules{$k}; # only pugs modules
 107     my $color = $edge->[1] ? 'green' : $edge->[0] ? "blue" : "black";
 108     $g->add_edge($name, $k, color => $color);
 109     $edges++;
 110   }
 111 }
 112 print "$nodes nodes and $edges edges\n";
 113
 114 #$g->as_canon("importgraph.dot");
 115 #$g->as_png("importgraph.png");
 116 $g->as_ps("importgraph.ps");