Roles pass any classes they're made to inherit along.

rakudo · Sep 21, 2011 · b72d678 · b72d678
1 parent 1dd4914
commit b72d678
Show file tree

Hide file tree

Showing 4 changed files with 33 additions and 1 deletion.
diff --git a/src/Perl6/Metamodel/ConcreteRoleHOW.pm b/src/Perl6/Metamodel/ConcreteRoleHOW.pm
@@ -17,6 +17,9 @@ class Perl6::Metamodel::ConcreteRoleHOW
 
     # Full flat list of done roles.
     has @!role_typecheck_list;
+
+    # Are we composed yet?
+    has $!composed;
 
     my $archetypes := Perl6::Metamodel::Archetypes.new( :nominal(1), :composable(1) );
     method archetypes() {
@@ -56,9 +59,14 @@ class Perl6::Metamodel::ConcreteRoleHOW
             }
         }
         self.publish_type_cache($obj);
+        $!composed := 1;
         $obj
     }
 
+    method is_composed($obj) {
+        $!composed ?? 1 !! 0
+    }
+
     method collisions($obj) {
         @!collisions
     }

diff --git a/src/Perl6/Metamodel/ParametricRoleHOW.pm b/src/Perl6/Metamodel/ParametricRoleHOW.pm
@@ -166,7 +166,15 @@ class Perl6::Metamodel::ParametricRoleHOW
             $conc.HOW.add_role($conc, $r.HOW.specialize($r, @pos_args[0]));
         }
 
-        # XXX More to copy/instantiate
+        # Pass along any parents that have been added, resolving them in
+        # the case they're generic (role Foo[::T] is T { })
+        for self.parents($obj, :local(1)) {
+            my $p := $_;
+            if $_.HOW.archetypes.generic {
+                $p := $p.HOW.instantiate_generic($p, $type_env);
+            }
+            $conc.HOW.add_parent($conc, $p);
+        }
 
         $conc.HOW.compose($conc);
         return $conc;

diff --git a/src/Perl6/Metamodel/RoleToClassApplier.pm b/src/Perl6/Metamodel/RoleToClassApplier.pm
@@ -84,6 +84,14 @@ my class RoleToClassApplier {
             $target.HOW.add_attribute($target, $_);
         }
 
+        # Compose in any parents.
+        if pir::can($to_compose_meta, 'parents') {
+            my @parents := $to_compose_meta.parents($to_compose, :local(1));
+            for @parents {
+                $target.HOW.add_parent($target, $_);
+            }
+        }
+
         1;
     }
 }
diff --git a/src/Perl6/Metamodel/RoleToRoleApplier.pm b/src/Perl6/Metamodel/RoleToRoleApplier.pm
@@ -105,6 +105,14 @@ my class RoleToRoleApplier {
                     $target.HOW.add_multi_method($target, $_.name, $_.code);
                 }
             }
+
+            # Any parents can also just be copied over.
+            if pir::can__IPs($how, 'parents') {
+                my @parents := $how.parents($_, :local(1));
+                for @parents {
+                    $target.HOW.add_parent($target, $_);
+                }
+            }
         }
 
         1;