Work in progress on compiler. It's blowing up right now.

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

package MooseX::Compiler;

use strict;
use warnings;

use B;
use Data::Dumper;
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 rename_to => (
    is        => 'ro',
    isa       => 'Str',
    predicate => '_has_rename_to',
);

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',
    clearer  => '_clear_package_statement',
);

has _end_node => (
    is       => 'ro',
    isa      => 'PPI::Statement',
    init_arg => undef,
    lazy     => 1,
    builder  => '_build_end_node',
);

sub compile_class {
    my $self = shift;

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

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

sub _sanity_check_class {
    my $self = shift;

    for my $attr ( $self->_class_meta()->get_all_attributes() ) {
        if ( $attr->has_trigger() ) {
            die sprintf(
                'This class (%s) has an attribute (%s) with a trigger. Triggers cannot be compiled.',
                $self->class(), $attr->name()
            );
        }

        if ( $attr->has_initializer() ) {
            die sprintf(
                'This class (%s) has an attribute (%s) with an initializer. Initializers cannot be compiled.',
                $self->class(), $attr->name()
            );
        }

        if ( $attr->has_type_constraint()
            && !$attr->type_constraint()->can_be_inlined() ) {

            die sprintf(
                'This class (%s) has an attribute (%s) with a type that cannot be inlined (%s)..',
                $self->class(), $attr->name(),
                $attr->type_constraint()->name()
            );
        }
    }
}

sub _modify_class_content {
    my $self = shift;

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

    return;
}

sub _maybe_rename_class {
    my $self = shift;

    return unless $self->_has_rename_to();

    $self->_insert_code(
        $self->_package_statement(),
        'package ' . $self->rename_to() . ';'
    );

    $self->_package_statement()->remove();

    $self->_clear_package_statement();

    return;
}

sub _fixup_line_numbers {
    my $self = shift;

    my $code = "#line 3\n";

    $self->_insert_code(
        $self->_package_statement()->snext_sibling(),
        $code,
        'before',
    );

    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();

        $self->_insert_code(
            $node,
            $replacement_code,
        );

        $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->_insert_code(
        $self->_package_statement(),
        $code,
    );

    return;
}

# XXX - replace this with something that looks at all the generated code for
# calls of the form Foo::Bar::quux(...) - also don't load modules that are
# already being used.
sub _load_required_modules {
    my $self = shift;

    my $code = join q{},
        map { "use $_ ();\n" }
        qw( Carp Moose::Error::Util Scalar::Util );
    $code .= "use MooseX::Compiler::FakeMoose;\n";

    $self->_insert_code(
        $self->_package_statement(),
        $code,
    );

    return;
}

sub _insert_code {
    my $self      = shift;
    my $statement = shift;
    my $code      = shift;
    my $before    = shift;

    my $method = $before ? 'insert_before' : 'insert_after';
    $statement->$method( $_->clone() )
        for PPI::Document->new( \$code )->children();

    return;
}

sub _inline_roles {
    return;
}

sub _inline_constructor {
    my $self = shift;

    my $environment = $self->_class_meta()->_eval_environment();

    # This should go away in the next major release of Moose (I hope).
    delete $environment->{'$meta'};

    # In the future, we need to work with Specio, which should make this
    # simpler (I hope).
    delete $environment->{'@type_constraint_bodies'};

    my $body = join "\n", $self->_class_meta()->_inline_new_object();
    if ( $body =~ /\$meta/ ) {
        die
            'Cannot compile a class with a constructor that refers to the $meta object';
    }

    my @defs = @{ ${ $environment->{'$defaults'} } };
    $environment->{'$defaults'} = \(
        [
            map { ref $defs[$_] ? '$___attributes[' . $_ . ']' : $defs[$_] }
                0 .. $#defs
        ]
    );

    my $constructor = join "\n", (
        '{',
        (
            map {
                $self->_serialize_assignment( $_, $environment->{$_} ) . ';'
                }
                keys %{$environment}
        ),
        'sub new {',
        $body,
        '}',
        '}',
    );

    $constructor .= "\n\n";

    $self->_insert_before_end($constructor);

    return;
}

sub _inline_attributes {
    my $self = shift;

    my $code;
    for my $attr ( $self->_class_meta()->get_all_attributes() ) {
        for my $method ( $attr->associated_methods() ) {
            # This is super gross, there really should be some sort of generic
            # "inlinable_method" thing
            my $generator_method = join "_" => (
                '_generate',
                $self->accessor_type,
                'method_inline',
            );

            $code .= $method->$generator_method();
        }
    }

    $self->_insert_before_end($code);

    return;
}

sub _serialize_assignment {
    my $self  = shift;
    my $name  = shift;
    my $value = shift;

    local $Data::Dumper::Terse     = 1;
    local $Data::Dumper::Indent    = 1;
    local $Data::Dumper::Useqq     = 1;
    local $Data::Dumper::Deparse   = 1;
    local $Data::Dumper::Quotekeys = 0;
    local $Data::Dumper::Sortkeys  = 1;

    return
          "my $name = "
        . substr( $name, 0, 1 ) . '{ '
        . Data::Dumper->Dump( [$value] ) . ' }';
}

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

    $self->_insert_code(
        $self->_end_node(),
        $code,
        'before',
    );

    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;
}

sub _build_end_node {
    my $self = 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;

    return $end_node;
}

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

1;