Added code to fixup line numbers, inline constructor, and load modules that construct...

[gitmo/MooseX-Compiler.git] / lib / MooseX / Compiler.pm

package MooseX::Compiler;

use strict;
use warnings;

use B;
use Module::Runtime qw( module_notional_filename );
use PPI::Document;
use Scalar::Util qw( blessed );

use Moose;
use Moose::Util::TypeConstraints;

my $moose_class = subtype, as 'ClassName', where {
    $_[0]->can('meta')
        && blessed $_[0]->meta()
        && $_[0]->meta()->isa('Moose::Meta::Class');
};

has class => (
    is       => 'ro',
    isa      => $moose_class,
    required => 1,
);

has _class_meta => (
    is       => 'ro',
    isa      => 'Moose::Meta::Class',
    init_arg => undef,
    lazy     => 1,
    default  => sub { $_[0]->class()->meta() },
);

has _ppi_document => (
    is       => 'ro',
    isa      => 'PPI::Document',
    init_arg => undef,
    lazy     => 1,
    builder  => '_build_ppi_document',
);

has _package_statement => (
    is       => 'ro',
    isa      => 'PPI::Statement::Package',
    init_arg => undef,
    lazy     => 1,
    builder  => '_build_package_statement',
);

sub compile_class {
    my $self = shift;

    $self->_modify_class_content();
    $self->_inline_roles();
    $self->_inline_constructor();
    $self->_inline_attributes();

    return $self->_ppi_document()->content();
}

sub _modify_class_content {
    my $self = shift;

    $self->_fixup_line_numbers();
    $self->_do_not_use_moose();
    $self->_inline_parents();
    $self->_load_required_modules();

    return;
}

sub _fixup_line_numbers {
    my $self = shift;

    my $code = "#line 3\n";
    $self->_package_statement()->snext_sibling()->insert_before( $_->clone() )
        for PPI::Document->new( \$code )->children();

    return;
}

sub _do_not_use_moose {
    my $self = shift;

    my $use_nodes = $self->_ppi_document()->find(
        sub {
            my $node = $_[1];
            return undef
                if $node->isa('PPI::Statement')
                    && !$node->isa('PPI::Statement::Include');
            return undef if $node->isa('PPI::Structure');
            return 1
                if $node->isa('PPI::Statement::Include')
                    && $node->module() =~ /^Moose/;
            return 0;
        }
    );

    for my $node ( @{$use_nodes} ) {
        my $replacement_code .=
            defined $node->module_version()
            ? join(
            q{ },
            'use', $node->module(), $node->module_version(), '()', ';',
            )
            : '# ' . $node->content();

        $node->insert_before( $_->clone() )
            for PPI::Document->new( \$replacement_code )->children();
        $node->remove();
    }

    return;
}

sub _inline_parents {
    my $self = shift;

    my @supers = $self->_class_meta()->superclasses();
    return unless @supers;

    my $code = 'use parent ';
    $code .= join ', ', map { B::perlstring($_) } @supers;
    $code .= ";\n";

    $self->_package_statement()->insert_after( $_->clone() )
        for PPI::Document->new( \$code )->children();

    return;
}

sub _load_required_modules {
    my $self = shift;

    my $code = "use Scalar::Util ();\nuse Moose::Error::Util ();\nuse Carp ();\n";

    $self->_package_statement()->insert_after( $_->clone() )
        for PPI::Document->new( \$code )->children();

    return;
}

sub _inline_roles {
    return;
}

sub _inline_constructor {
    my $self = shift;

    my $constructor = join "\n",
        (
        'sub new {',
        $self->_class_meta()->_inline_new_object(),
        '}'
        );

    $constructor .= "\n\n";

    $self->_insert_before_end($constructor);

    return;
}

sub _inline_attributes {
    return;
}

sub _insert_before_end {
    my $self = shift;
    my $code = shift;

    my $end_node = $self->_ppi_document()->find_first(
        sub {
            my $node = $_[1];

            return 1
                if $node->isa('PPI::Statement') && $node->content() =~ /^1;/;
            return 0;
        }
    );

    die 'Cannot find the end of the class (looking for a line match /^1;/)'
        unless $end_node;

    $end_node->insert_before( $_->clone() )
        for PPI::Document->new( \$code )->children();

    return;
}

sub _build_ppi_document {
    my $self = shift;

    my $pm_file       = module_notional_filename( $self->class() );
    my $path_to_class = $INC{$pm_file}
        or die "Cannot find $pm_file in %INC!";

    return PPI::Document->new( $path_to_class->stringify() )
        or die PPI::Document->errstr();
}

sub _build_package_statement {
    my $self = shift;

    my $package_stmt = $self->_ppi_document()->find_first(
        sub {
            my $node = $_[1];
            return 1 if $_[1]->isa('PPI::Statement::Package');
            return 0;
        }
    );

    die 'Cannot find a package statement in this code'
        unless $package_stmt;

    return $package_stmt;
}

__PACKAGE__->meta()->make_immutable();

1;