Implement does so roles can be composed. Based on the meta-object, do…

… code generation a little differently for bodies of parametric types. Have NQPClassHOW instantiate the role with the correct type object and add it and the generic version to its roles done list. .^does works as a result. Also update type check cache publisher to know about roles. Missing: all the rest of composition.

src/NQP/Actions.pm

@@ -381,12 +381,6 @@ method package_def($/) {
     # Get the body code.
     my $past := $<block> ?? $<block>.ast !! $<comp_unit>.ast;
     $past.namespace( $<name><identifier> );
-    $past.blocktype('immediate');
-
-    # Evaluate anything else in the package in-line; also give it a $?CLASS
-    # lexical. XXX Due to Parrot static lexpad fail, it's currently package scoped.
-    $past.unshift(PAST::Var.new( :name('$?CLASS'), :scope('package'), :isdecl(1) ));
-    $past.symbol('$?CLASS', :scope('package'));
 
     # Prefix the class initialization with initial setup. Also install it
     # in the symbol table right away.
@@ -408,12 +402,31 @@ method package_def($/) {
             PAST::Var.new( :name('type_obj'), :scope('register') )
         )
     ));
+
+    # Pass along a custom REPR if one is selected.
     if $<repr> {
         my $repr_name := $<repr>[0].ast;
         $repr_name.named('repr');
         $*PACKAGE-SETUP[0][0][1].push($repr_name);
     }
 
+    # Evaluate everything in the package in-line unless this is a generic
+    # type in which case it needs delayed evaluation. Normally, $?CLASS is
+    # a lexical that is set (XXX currently package-scoped as Parrot does not
+    # do static lexpads) but for generic types it becomes a parameter. Also
+    # for parametric types, pass along the role body block.
+    if pir::can($how, 'parametric') && $how.parametric($how) {
+        $past.blocktype('declaration');
+        $past.unshift(PAST::Var.new( :name('$?CLASS'), :scope('parameter') ));
+        $past.symbol('$?CLASS', :scope('lexical'));
+        $*PACKAGE-SETUP[0][0][1].push(PAST::Val.new( :value($past), :named('body_block') ));
+    }
+    else {
+        $past.blocktype('immediate');
+        $past.unshift(PAST::Var.new( :name('$?CLASS'), :scope('package'), :isdecl(1) ));
+        $past.symbol('$?CLASS', :scope('package'));
+    }
+
     # Add call to add_parent if we have one.
     # XXX Doesn't handle lexical classes yet.
     if $<parent> {
@@ -443,6 +456,24 @@ method package_def($/) {
         ));
     }
 
+    # Add any done roles.
+    if $<role> {
+        for $<role> {
+            my @ns := pir::clone__PP($_<identifier>);
+            my $name := ~@ns.pop;
+            $*PACKAGE-SETUP.push(PAST::Op.new(
+                :pasttype('callmethod'), :name('add_role'),
+                PAST::Op.new(
+                    # XXX nqpop get_how
+                    :pirop('get_how PP'),
+                    PAST::Var.new( :name('type_obj'), :scope('register') )
+                ),
+                PAST::Var.new( :name('type_obj'), :scope('register') ),
+                PAST::Var.new( :name(~$name), :namespace(@ns), :scope('package') )
+            ));
+        }
+    }
+
     # Postfix it with a call to compose.
     $*PACKAGE-SETUP.push(PAST::Op.new(
         :pasttype('callmethod'), :name('compose'),
@@ -675,7 +706,7 @@ method method_def($/) {
     unless $past<signature_has_invocant> {
         $past[0].unshift(PAST::Var.new(
             :name('self'), :scope('parameter'),
-            :multitype(PAST::Var.new( :name('$?CLASS'), :scope('package') ))
+            :multitype(PAST::Var.new( :name('$?CLASS') ))
         ));
     }
     $past.symbol('self', :scope('lexical') );

src/NQP/Grammar.pm

@@ -314,6 +314,7 @@ rule package_def {
     <name>
     [ 'is' 'repr(' <repr=.quote_EXPR> ')' ]?
     [ 'is' <parent=.name> ]?
+    [ 'does' <role=.name> ]*
     [
     || ';' <comp_unit>
     || <?[{]> <block>

src/metamodel/how/NQPClassHOW.pm

@@ -94,8 +94,26 @@ knowhow NQPClassHOW {
         @!parents[+@!parents] := $parent;
     }
 
+    method add_role($obj, $role) {
+        for @!roles {
+            if $_ =:= $role {
+                pir::die("The role " ~ $role ~ " has already been added.");
+            }
+        }
+        @!roles[+@!roles] := $role;
+    }
+
     method compose($obj) {
-        # XXX roles...
+        # Incorporate roles. First, instantiate them with the type object
+        # for this type (so their $?CLASS is correct).
+        my @instantiated_roles;
+        for @!roles {
+            my $ins := $_.HOW.instantiate($_, $obj);
+            @instantiated_roles.push($ins);
+            @!done[+@!done] := $_;
+            @!done[+@!done] := $ins;
+        }
+        # XXX TODO: Actually compose.
 
         # If we have no parents and we're not called NQPMu then add NQPMu as
         # our parent.
@@ -263,8 +281,10 @@ knowhow NQPClassHOW {
     }
 
     method publish_type_cache($obj) {
-        # XXX TODO: when we have roles, need these here too.
-        pir::publish_type_check_cache($obj, @!mro)
+        my @tc;
+        for @!mro { @tc.push($_); }
+        for @!done { @tc.push($_); }
+        pir::publish_type_check_cache($obj, @tc)
     }
 
     method publish_method_cache($obj) {

src/metamodel/how/NQPParametricRoleHOW.pm

@@ -67,7 +67,7 @@ knowhow NQPParametricRoleHOW {
     method instantiate($obj, *@pos_args, *%named_args) {
         # Run the body block to capture the arguments into the correct
         # type argument context.
-        $!body_block();
+        $!body_block(|@pos_args, |%named_args);
 
         # Construct a new concrete role.
         my $irole := NQPConcreteRoleHOW.new_type(:name($!name));