Commit this failed experiment

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

# 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 = "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 $environment = $self->_class_meta()->_eval_environment();
    delete $environment->{'$meta'};
    delete $environment->{'@type_constraint_bodies'};

    if ( grep { defined } @{ ${ $environment->{'$triggers'} } || [] } ) {
        die 'Cannot compile a class with triggers for attributes';
    }

    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 _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
          "$name = "
        . substr( $name, 0, 1 ) . '{ '
        . Data::Dumper->Dump( [$value] ) . ' }';
}

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;