Implement basic augment syntax

src/CompilerDriver.pm

@@ -94,6 +94,10 @@ sub find_module {
         my $self = shift;
         my $module = shift;
 
+        # these are handled in the compiler itself
+        return { } if $module eq 'MONKEY_TYPING' || $module eq 'lib' ||
+            $module eq 'fatal';
+
         my $csmod = $module;
         $csmod =~ s/::/./g;
         my ($symlfile) = File::Spec->catfile($builddir, "$csmod.store");

src/Decl.pm

@@ -243,6 +243,49 @@ use CgOp;
     no Moose;
 }
 
+{
+    package Decl::Augment;
+    use Moose;
+    extends 'Decl';
+
+    has body    => (is => 'ro', isa => 'Body', required => 1);
+    has bodyvar => (is => 'ro', isa => 'Str', required => 1);
+    has name    => (is => 'ro', isa => 'Str', required => 1);
+    has pkg     => (is => 'ro', isa => 'ArrayRef[Str]', required => 1);
+
+    sub bodies { $_[0]->body }
+
+    sub stash {
+        my ($self, $body, $suf) = @_;
+        ($body->lookup_pkg(@{ $self->pkg }, $self->name . $suf))[1];
+    }
+
+    sub used_slots {
+        my ($self) = @_;
+        [$self->bodyvar, 'Variable', $_[1] ? 1 : 4];
+    }
+
+    sub needs_protopad { 1 }
+    sub preinit_code {
+        my ($self, $body) = @_;
+
+        CgOp::letn("pkg", $self->stash($body, '::'),
+            CgOp::letn("how", CgOp::newscalar(CgOp::how(
+                        CgOp::fetch($self->stash($body, '')))),
+                CgOp::protosub($self->body),
+                CgOp::proto_var($self->bodyvar, CgOp::sub_var($self->body))));
+    }
+
+    sub enter_code {
+        my ($self, $body) = @_;
+        ($body->mainline) ? CgOp::noop :
+            CgOp::scopedlex($self->bodyvar, CgOp::sub_var($self->body));
+    }
+
+    __PACKAGE__->meta->make_immutable;
+    no Moose;
+}
+
 {
     package Decl::Package;
     use Moose;

src/Niecza/Actions.pm

@@ -2065,6 +2065,10 @@ sub statement_control__S_use { my ($cl, $M) = @_;
         return;
     }
 
+    if ($name eq 'MONKEY_TYPING' || $name eq 'fatal' || $name eq 'lib') {
+        return;
+    }
+
     my $meta = CompilerDriver::metadata_for($name);
     $::UNITREFS{$name} = 1;
     $::UNITREFSTRANS{$name} = 1;
@@ -2101,8 +2105,8 @@ sub package_def { my ($cl, $M) = @_;
     if (!$M->{longname}[0]) {
         $scope = 'anon';
     }
-    if ($scope eq 'augment' || $scope eq 'supersede') {
-        $M->sorry('Monkey typing is not yet supported');
+    if ($scope eq 'supersede') {
+        $M->sorry('Supercede is not yet supported');
         return;
     }
     if ($scope eq 'has' || $scope eq 'state') {
@@ -2120,7 +2124,18 @@ sub package_def { my ($cl, $M) = @_;
     # currently always install into the local stash
     my $ourpkg = ($scope eq 'our') ? [ 'OUR::' ] : undef;
 
-    if (!$M->{decl}{stub}) {
+    if ($scope eq 'augment') {
+        my $stmts = $M->{statementlist} // $M->{blockoid};
+        $stmts = $stmts->{_ast};
+        my $cbody = $cl->sl_to_block($blocktype, $stmts, name => $name);
+
+        $M->{_ast} = Op::Augment->new(
+            node($M),
+            pkg     => [],
+            name    => $name,
+            bodyvar => $bodyvar,
+            body    => $cbody);
+    } elsif (!$M->{decl}{stub}) {
         my $stmts = $M->{statementlist} // $M->{blockoid};
         my @export;
 

src/Op.pm

@@ -586,6 +586,31 @@ use CgOp;
     no Moose;
 }
 
+{
+    package Op::Augment;
+    use Moose;
+    extends 'Op';
+
+    has name => (is => 'ro', isa => 'Str');
+    has bodyvar => (is => 'ro', isa => 'Str');
+    has body => (is => 'ro', isa => 'Body');
+    has pkg => (is => 'ro', isa => 'ArrayRef[Str]');
+
+    sub lift_decls {
+        my ($self) = @_;
+        Decl::Augment->new(name => $self->name, bodyvar => $self->bodyvar,
+            pkg => $self->pkg, body => $self->body);
+    }
+
+    sub code {
+        my ($self, $body) = @_;
+        CgOp::subcall(CgOp::fetch(CgOp::scopedlex($self->bodyvar)));
+    }
+
+    __PACKAGE__->meta->make_immutable;
+    no Moose;
+}
+
 {
     package Op::PackageDef;
     use Moose;

test2.pl

@@ -1,4 +1,21 @@
 # vim: ft=perl6
 use Test;
 
+{
+    use MONKEY_TYPING;
+    my class Foo {
+        method foo { 1 }
+    }
+    is Foo.foo, 2, "augments run early";
+    is Any.g4077, 4077, "can augment core classes";
+    is Cool.g4077, 4077, "augments visible in subclasses";
+
+    augment class Foo {
+        method foo { 2 }
+    }
+    augment class Any {
+        method g4077 { 4077 }
+    }
+}
+
 done-testing;