path: root/tools/uml_blueprint.pl

#!/usr/bin/env perl
#
# uml_blueprint.pl — generate a PlantUML class diagram from OCaml sources.
#
# Each module (an *.ml / *.mli file) becomes a class:
#   - types -> fields
#   - vals  -> methods (with a best-effort return type)
#
# Edges are DECLARED, not guessed. A signature has no bodies, so a call graph
# cannot be recovered from it, and scraping .ml bodies is a heuristic that lies
# on aliases, opens and functor params. Instead the author states each edge in a
# comment tag, anywhere in the module's .ml/.mli:
#
#   (* @uses  <Module> [-- <note>] *)   solid  A --> B : <note>   (a real call)
#   (* @needs <Module> [<Module>...] *) dashed A ..> B            (type-only)
#
# Example (lib/backend/managers/Lifecycle.mli):
#   (* @uses Object -- calls register/unregister *)
#   (* @needs Path *)
# yields:
#   Lifecycle --> Object : calls register/unregister
#   Lifecycle ..> Path
#
# A tag naming an unknown module is reported on stderr (typo guard for CI).
#
# Usage: perl tools/uml_blueprint.pl --src lib --out docs/architecture.puml

use strict;
use warnings;
use File::Find ();
use Getopt::Long ();

my $src   = 'lib';
my $out   = '-';
my $title = 'RNT Architecture';
my $strict   = 0;    # --strict:   exit non-zero if a tag names an unknown module
my $no_notes = 0;    # --no-notes: drop @uses edge labels (pristine edges)
Getopt::Long::GetOptions(
  'src=s'    => \$src,
  'out=s'    => \$out,
  'title=s'  => \$title,
  'strict'   => \$strict,
  'no-notes' => \$no_notes,
) or die "usage: $0 [--src DIR] [--out FILE] [--title STR] [--strict] [--no-notes]\n";

# ---------------------------------------------------------------------------
# 1. Discover modules. A module is a capitalised *.ml / *.mli basename.
# ---------------------------------------------------------------------------
my %mod;    # base => { ml => path, mli => path }
File::Find::find(
  sub {
    return unless -f $_;
    return unless /\A([A-Z][A-Za-z0-9_']*)\.(mli?)\z/;
    $mod{$1}{ $2 eq 'mli' ? 'mli' : 'ml' } = $File::Find::name;
  },
  $src
);
my %known = map { $_ => 1 } keys %mod;
die "no OCaml modules found under $src\n" unless %known;

# ---------------------------------------------------------------------------
# Helpers.
# ---------------------------------------------------------------------------
sub slurp {
  my ($f) = @_;
  open my $fh, '<', $f or die "$f: $!\n";
  local $/;
  return <$fh>;
}

# Remove OCaml comments (nested (* *)) and string literals, so a keyword inside
# either cannot masquerade as a member. Tags are read from the RAW text; members
# from this stripped text.
sub strip {
  my ($s) = @_;
  my ($i, $n, $depth, $keep) = (0, length $s, 0, '');
  while ($i < $n) {
    my $two = substr($s, $i, 2);
    if ($depth == 0 && $two eq '(*') { $depth = 1; $i += 2; next; }
    if ($depth > 0) {
      if    ($two eq '(*') { $depth++; $i += 2; next; }
      elsif ($two eq '*)') { $depth--; $i += 2; next; }
      $i++;
      next;
    }
    my $c = substr($s, $i, 1);
    if ($c eq '"') {    # skip a string literal, honouring \" escapes
      $i++;
      while ($i < $n) {
        my $d = substr($s, $i, 1);
        if    ($d eq '\\') { $i += 2; next; }
        elsif ($d eq '"')  { $i++; last; }
        $i++;
      }
      $keep .= ' ';
      next;
    }
    $keep .= $c;
    $i++;
  }
  return $keep;
}

sub clean_name {          # strip the parens off an operator val, e.g. ( |=| )
  my ($n) = @_;
  $n =~ s/\A\(\s*//;
  $n =~ s/\s*\)\z//;
  return $n;
}

sub ret_of {              # best-effort return type: text after the last arrow
  my ($s) = @_;
  $s =~ s/\s+/ /g;
  $s = $1 if $s =~ /.*->\s*(.*)\z/s;
  $s =~ s/[(){}:]/ /g;                    # keep it a valid PlantUML label
  $s =~ s/\s+/ /g;
  $s =~ s/\A\s+|\s+\z//g;
  $s = substr($s, 0, 57) . '...' if length $s > 60;
  return $s;
}

sub uniq {
  my %seen;
  return grep { !$seen{$_}++ } @_;
}

# Members from a signature (.mli).
sub parse_sig {
  my ($t) = @_;
  my (@types, @vals);
  while ($t =~ /(?<![\w'])(?:type|and)\s+(?:\([^)]*\)\s+|'[\w']+\s+)*([a-z_][\w']*)/g) {
    push @types, $1;
  }
  while ($t =~ /(?<![\w'])val\s+(\([^)]*\)|[a-z_][\w']*)\s*:\s*
                (.*?)(?=(?:\bval\b|\btype\b|\band\b|\bmodule\b|\binclude\b|\bend\b)|\z)/gsx) {
    push @vals, [ clean_name($1), ret_of($2) ];
  }
  return (\@types, \@vals);
}

# Members from an implementation (.ml) — used when a module has no .mli.
# Only column-0 `let`/`type` count, so local bindings are ignored.
sub parse_impl {
  my ($t) = @_;
  my (@types, @vals);
  while ($t =~ /(?<![\w'])(?:type|and)\s+(?:\([^)]*\)\s+|'[\w']+\s+)*([a-z_][\w']*)/g) {
    push @types, $1;
  }
  while ($t =~ /(?:\A|\n)let\s+(?:rec\s+)?(\([^)]*\)|[a-z_][\w']*)/g) {
    push @vals, [ clean_name($1), '' ];
  }
  return (\@types, \@vals);
}

# Declared edges from tags in the RAW text of a module.
#   @composes B [-- note] -> ('composes', B, note)   functor param / application
#   @uses     B [-- note] -> ('uses', B, note)       declared call
#   @needs    B [C ...]   -> ('needs', B, undef)     type-only coupling
my $warned = 0;
sub parse_tags {
  my ($raw, $self) = @_;
  my @edges;
  for my $kw (qw(composes uses)) {
    while ($raw =~ /\@$kw\s+([A-Z][\w']*)\s*(?:--\s*(.+?))?\s*(?:\*\)|\R|\z)/g) {
      my ($b, $note) = ($1, $2);
      $note =~ s/\s+\z// if defined $note;
      push @edges, [ $kw, $b, $note ];
    }
  }
  while ($raw =~ /\@needs\s+((?:[A-Z][\w']*[,\s]*)+)/g) {
    push @edges, [ 'needs', $_, undef ] for ($1 =~ /([A-Z][\w']*)/g);
  }
  for my $e (@edges) {
    my $b = $e->[1];
    if (!$known{$b}) {
      warn "$self: \@$e->[0] names unknown module '$b'\n";
      $warned++;
    }
  }
  return grep { $known{ $_->[1] } && $_->[1] ne $self } @edges;
}

# ---------------------------------------------------------------------------
# 2. Build classes and edges.
# ---------------------------------------------------------------------------
my (%types, %vals, %edges);
for my $m (keys %mod) {
  my $raw_sig  = $mod{$m}{mli} ? slurp($mod{$m}{mli}) : '';
  my $raw_impl = $mod{$m}{ml}  ? slurp($mod{$m}{ml})  : '';

  if ($raw_sig ne '') { ($types{$m}, $vals{$m}) = parse_sig(strip($raw_sig)); }
  else                { ($types{$m}, $vals{$m}) = parse_impl(strip($raw_impl)); }

  # Tags may live in either file.
  $edges{$m} = [ parse_tags($raw_sig, $m), parse_tags($raw_impl, $m) ];
}

# ---------------------------------------------------------------------------
# 3. Emit PlantUML.
# ---------------------------------------------------------------------------
my $fh;
if ($out eq '-') { $fh = \*STDOUT; }
else { open $fh, '>', $out or die "$out: $!\n"; }

print {$fh} "\@startuml\n";
print {$fh} "!theme toy\n";
print {$fh} "title $title\n";
print {$fh} "hide empty members\n";
print {$fh} "skinparam classAttributeIconSize 0\n";
# Orthogonal routing: straight segments with right-angle turns instead of
# curved splines. Use "polyline" for straight-but-diagonal edges instead.
print {$fh} "skinparam linetype ortho\n";
# Keep the graph compact so it does not shrink to unreadable when fit to width,
# but leave enough gap that ortho channels do not merge. Larger font offsets the
# tighter packing.
print {$fh} "skinparam nodesep 30\n";
print {$fh} "skinparam ranksep 50\n";
print {$fh} "skinparam defaultFontSize 15\n";
print {$fh} "left to right direction\n\n";

for my $m (sort keys %mod) {
  print {$fh} "class $m <<module>> {\n";
  my @t = uniq(@{ $types{$m} });
  if (@t) {
    print {$fh} "  .. types ..\n";
    print {$fh} "  +$_\n" for @t;
  }
  my @v = uniq(map { $_->[0] } @{ $vals{$m} });
  my %ret = map { $_->[0] => $_->[1] } @{ $vals{$m} };
  if (@v) {
    print {$fh} "  .. values ..\n";
    for my $name (@v) {
      if ($name =~ /\A[a-z_][\w']*\z/) {
        print {$fh} $ret{$name} ? "  +$name() : $ret{$name}\n" : "  +$name()\n";
      }
      else { print {$fh} "  +\"$name\"\n"; }    # operator, rendered flat
    }
  }
  print {$fh} "}\n\n";
}

# One edge per pair: the strongest declared relation wins.
#   composes (3) *--   >   uses (2) -->   >   needs (1) ..>
my %rank = (composes => 3, uses => 2, needs => 1);
my %best;    # "from|to" => [kind, note]
for my $from (sort keys %mod) {
  for my $e (@{ $edges{$from} }) {
    my ($kind, $to, $note) = @$e;
    my $key = "$from|$to";
    next if $best{$key} && $rank{ $best{$key}[0] } >= $rank{$kind};
    $best{$key} = [ $kind, $note ];
  }
}
for my $key (sort keys %best) {
  my ($from, $to) = split /\|/, $key;
  my ($kind, $note) = @{ $best{$key} };
  my $arrow = $kind eq 'composes' ? '*--' : $kind eq 'uses' ? '-->' : '..>';
  my $label = (!$no_notes && defined $note && $note ne '') ? " : $note" : '';
  print {$fh} "$from $arrow $to$label\n";
}

print {$fh} "\nlegend right\n";
print {$fh} "  diamond A *-- B : functor composition (\@composes)\n";
print {$fh} "  solid   A --> B : declared call (\@uses)\n";
print {$fh} "  dashed  A ..> B : type-only coupling (\@needs)\n";
print {$fh} "endlegend\n";
print {$fh} "\@enduml\n";

close $fh if $out ne '-';

exit 2 if $strict && $warned;