#!/usr/bin/perl

use strict;
use warnings;
use autodie;

# We want to make sure that when we load an exception class we're getting the
# version for the release-to-be, not the installed version.
use blib;

use Module::Runtime qw( require_module );
use Moose::Util qw( english_list find_meta );
use Path::Tiny qw( path );

sub main {
    my $exception_dir = path(qw( lib Moose Exception ));

    my @classes;

    my $iter = $exception_dir->iterator();
    while ( my $file = $iter->() ) {
        next if $file->is_dir();

        my ($class) = $file =~ m{.*(Moose/Exception/.+)\.pm};
        $class =~ s{/}{::}g;

        require_module($class);
        push @classes, $class;
    }

    print_header();

    for my $class (sort @classes) {
        print_class_manifest($class);
    }

    print_footer();
}

sub print_header {
    print <<'EOF';
=head1 DESCRIPTION

This document contains a manifest of all the exception classes that are thrown
as Moose internal errors.

=head1 COMMON ELEMENTS

Unless otherwise stated, all classes are subclasses of L<Moose::Exception>.

Similarly, all classes provide the following attribute reader methods:

=head2 $exception->message

This method returns the error message for the exception.

=head2 $exception->trace

This method returns a L<Devel::StackTrace> object.

=head1 EXCEPTION CLASSES

Moose ships with the following exception classes:

EOF
}

sub print_class_manifest {
    my $class = shift;

    my $meta = find_meta($class) or return;

    print '=head2 ' . $class . "\n\n";

    my $superclass_text = _superclass_text_for($meta);
    my $role_text = _role_text_for($meta);

    if ($superclass_text || $role_text) {
        print join q{ }, grep { defined } $superclass_text, $role_text;
        print "\n\n";
    }

    print _attribute_text_for($meta);
    print "\n";
}

sub _superclass_text_for {
    my $meta = shift;

    my @superclasses = $meta->superclasses();

    if ( !@superclasses ) {
        die $meta->name . ' does not have any superclasses!';
    }

    return unless @superclasses > 1 || $superclasses[0] ne 'Moose::Exception';

    return
        'This class is a subclass of '
        . linked_english_list(@superclasses) . '.';
}

sub _role_text_for {
    my $meta = shift;

    # The individual members of composite roles will also show up individually
    # in the return value of calculate_all_roles()
    my @roles = sort { $a cmp $b }
        grep { !/\|/ }
        map  { $_->name() } $meta->calculate_all_roles();

    return unless @roles;

    # Change to linked_english_list if we ever add POD for each exception role.
    my $role_noun = @roles > 1 ? 'roles' : 'role';
    return 'This class consumes the ' . english_list(@roles) . " $role_noun.";
}

my %common = map { $_ => 1 } qw( message trace );
sub _attribute_text_for {
    my $meta = shift;

    for my $attr_name ( keys %common ) {
        unless ( $meta->find_attribute_by_name($attr_name) ) {
            die $meta->name . " has no $attr_name attribute!";
        }
    }

    my @attributes = sort { $a->name() cmp $b->name() }
        grep { !$common{ $_->name() } } $meta->get_all_attributes();

    unless (@attributes) {
        return "This class has no attributes except for C<message> and C<trace()>.\n";
    }

    my $text = "This class has the following methods:\n\n";

    $text .= "=over 4\n\n";
    for my $attr (@attributes) {
        $text .= _one_attribute_text( $meta, $attr );
    }
    $text .= "=back\n";

    return $text;
}

sub _one_attribute_text {
    my $meta = shift;
    my $attr = shift;

    my $text = q{};
    if ( my $reader = $attr->get_read_method() ) {
        $text = '=item * $exception->' . "$reader()\n\n";
        if ( $attr->has_type_constraint() ) {
            $text .= _type_constraint_text($attr);
        }
    }
    elsif ( $attr->has_handles() ) {
        for my $method ( %{ $attr->handles() } ) {
            $text .= '=item * $exception->' . "$method()\n\n";
        }
    }
    else {
        die 'no read method name or handles for '
            . $attr->name() . ' in '
            . $meta->name() . '!';
    }

    if ( $attr->has_documentation() ) {
        my $doc = $attr->documentation();
        # This ensures that code sections in the documentation are separated
        # from preceding text.
        $doc =~ s/\n    /\n\n    /;
        $text .= "$doc\n\n";
    }

    return $text;
}

sub _type_constraint_text {
    my $attr = shift;

    my $tc = $attr->type_constraint();

    return q{} if $tc->name() eq 'Any';

    my $tc_name;
    if ( $tc->isa('Moose::Meta::TypeConstraint::Class') ) {
        $tc_name = 'L<' . $tc->class() . '> object';
    }
    elsif ( $tc->isa('Moose::Meta::TypeConstraint::Role') ) {
        $tc_name     = 'object which does the L<' . $tc->class() . '> role';
    }
    else {
        $tc_name = $tc->name() . ' value';
    }

    my $preposition = $tc_name =~ /^[aeiou]/i ? 'an' : 'a';

    return "Returns $preposition $tc_name.\n\n";
}

sub linked_english_list {
    my @items = @_;

    return unless @items;

    return english_list( map {"L<$_>"} @items );
}

sub print_footer {
    print "=cut\n";
}

main();