From: Dave Rolsky <autarch@urth.org>
Date: Sun, 16 Jun 2013 15:29:49 +0000 (-0500)
Subject: Work in progress on compiler. It's blowing up right now.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=master;p=gitmo%2FMooseX-Compiler.git

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

diff --git a/lib/MooseX/Compiler.pm b/lib/MooseX/Compiler.pm
index 813c816..8cd97f7 100644
--- a/lib/MooseX/Compiler.pm
+++ b/lib/MooseX/Compiler.pm
@@ -24,6 +24,12 @@ has class => (
     required => 1,
 );
 
+has rename_to => (
+    is        => 'ro',
+    isa       => 'Str',
+    predicate => '_has_rename_to',
+);
+
 has _class_meta => (
     is       => 'ro',
     isa      => 'Moose::Meta::Class',
@@ -46,11 +52,21 @@ has _package_statement => (
     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();
@@ -59,9 +75,40 @@ sub compile_class {
     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();
@@ -70,12 +117,33 @@ sub _modify_class_content {
     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->_package_statement()->snext_sibling()->insert_before( $_->clone() )
-        for PPI::Document->new( \$code )->children();
+
+    $self->_insert_code(
+        $self->_package_statement()->snext_sibling(),
+        $code,
+        'before',
+    );
 
     return;
 }
@@ -106,8 +174,11 @@ sub _do_not_use_moose {
             )
             : '# ' . $node->content();
 
-        $node->insert_before( $_->clone() )
-            for PPI::Document->new( \$replacement_code )->children();
+        $self->_insert_code(
+            $node,
+            $replacement_code,
+        );
+
         $node->remove();
     }
 
@@ -124,8 +195,10 @@ sub _inline_parents {
     $code .= join ', ', map { B::perlstring($_) } @supers;
     $code .= ";\n";
 
-    $self->_package_statement()->insert_after( $_->clone() )
-        for PPI::Document->new( \$code )->children();
+    $self->_insert_code(
+        $self->_package_statement(),
+        $code,
+    );
 
     return;
 }
@@ -136,9 +209,27 @@ sub _inline_parents {
 sub _load_required_modules {
     my $self = shift;
 
-    my $code = "use Scalar::Util ();\nuse Moose::Error::Util ();\nuse Carp ();\n";
+    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;
+}
 
-    $self->_package_statement()->insert_after( $_->clone() )
+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;
@@ -152,12 +243,13 @@ 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'};
-    delete $environment->{'@type_constraint_bodies'};
 
-    if ( grep { defined } @{ ${ $environment->{'$triggers'} } || [] } ) {
-        die 'Cannot compile a class with triggers for attributes';
-    }
+    # 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/ ) {
@@ -194,6 +286,29 @@ sub _inline_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;
@@ -207,35 +322,21 @@ sub _serialize_assignment {
     local $Data::Dumper::Sortkeys  = 1;
 
     return
-          "$name = "
+          "my $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;
-        }
+    $self->_insert_code(
+        $self->_end_node(),
+        $code,
+        'before',
     );
 
-    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;
 }
 
@@ -267,6 +368,25 @@ sub _build_package_statement {
     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;
diff --git a/lib/MooseX/Compiler/FakeMoose.pm b/lib/MooseX/Compiler/FakeMoose.pm
new file mode 100644
index 0000000..f956f79
--- /dev/null
+++ b/lib/MooseX/Compiler/FakeMoose.pm
@@ -0,0 +1,23 @@
+package MooseX::Compiler::FakeMoose;
+
+use strict;
+use warnings;
+
+use Exporter qw( import );
+
+our @EXPORT = qw(
+    extends
+    has
+    meta
+    with
+);
+
+sub extends { }
+sub has     { }
+sub with    { }
+
+sub meta {
+    die 'meta() is not implemented yet';
+}
+
+1;
diff --git a/t/constructor.t b/t/constructor.t
index ffbc1f7..10f1212 100644
--- a/t/constructor.t
+++ b/t/constructor.t
@@ -3,7 +3,7 @@ use warnings;
 
 use lib 't/lib';
 
-use Test::MooseX::Compiler qw( save_fragment );
+use Test::MooseX::Compiler qw( save_fragment code_compiles_ok );
 use Test::More 0.88;
 
 use MooseX::Compiler;
@@ -45,28 +45,34 @@ use Moose;
 
 has a1 => (
     is      => 'ro',
-    isa     => 'Int',
     default => 42,
 );
 
-sub foo { 42 }
+sub foo { 84 }
 EOF
 
     my $class = 'Test::Class2';
     save_fragment( $class, $code );
 
     my $compiler = MooseX::Compiler->new(
-        class => $class,
+        class     => $class,
+        rename_to => 'Test::Class2::Compiled',
     );
 
     my $compiled = $compiler->compile_class();
-warn $compiled;
 
     like(
         $compiled,
         qr/sub new {.+\n}\n/s,
         'compiled code has a constructor'
     );
+
+    code_compiles_ok($compiled);
+
+    my $obj = Test::Class2::Compiled->new();
+    isa_ok( $obj, 'Test::Class2::Compiled', 'compiled object constructor' );
+    is( $obj->a1(), 'a1 attr defaults to 42' );
+    is( $obj->foo(), 84, 'foo method works' );
 }
 
 done_testing();
diff --git a/t/lib/Test/MooseX/Compiler.pm b/t/lib/Test/MooseX/Compiler.pm
index e6cfb89..c8ea849 100644
--- a/t/lib/Test/MooseX/Compiler.pm
+++ b/t/lib/Test/MooseX/Compiler.pm
@@ -8,8 +8,10 @@ use Exporter qw( import );
 use File::Temp qw( tempdir );
 use Module::Runtime qw( module_notional_filename );
 use Path::Class qw( dir );
+use Test::More;
 
 our @EXPORT_OK = qw(
+    code_compiles_ok
     save_class
     save_fragment
 );
@@ -57,4 +59,20 @@ sub save_class {
     return $pm_file;
 }
 
+sub code_compiles_ok {
+    my $code = shift;
+
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+    my $e;
+    {
+        local $@;
+        local $SIG{__DIE__};
+        eval $code;
+        $e = $@;
+    }
+
+    is( $e, q{}, 'code compiled ok' );
+}
+
 1;