Big refactor of role type checking. Includes an initial implementatio…

…n of role introspection (.^roles), supporting :local in classes (don't show me my parent's roles) and :transitive (show me the roles that my roles do too).
rakudo · Sep 9, 2011 · 46e7cc8 · 46e7cc8
1 parent 88e14a0
commit 46e7cc8
Show file tree

Hide file tree

Showing 7 changed files with 137 additions and 33 deletions.
diff --git a/src/Perl6/Metamodel/ClassHOW.pm b/src/Perl6/Metamodel/ClassHOW.pm
@@ -19,7 +19,8 @@ class Perl6::Metamodel::ClassHOW
     does Perl6::Metamodel::BoolificationProtocol
     does Perl6::Metamodel::ParrotInterop
 {
-    has @!does_list;
+    has @!roles;
+    has @!role_typecheck_list;
     has @!fallbacks;
     has $!composed;
 
@@ -56,9 +57,19 @@ class Perl6::Metamodel::ClassHOW
             my @ins_roles;
             while @roles_to_compose {
                 my $r := @roles_to_compose.pop();
+                @!roles[+@!roles] := $r;
                 @ins_roles.push($r.HOW.specialize($r, $obj))
             }
-            @!does_list := RoleToClassApplier.apply($obj, @ins_roles)
+            RoleToClassApplier.apply($obj, @ins_roles);
+
+            # Add them to the typecheck list, and pull in their
+            # own type check lists also.
+            for @ins_roles {
+                @!role_typecheck_list[+@!role_typecheck_list] := $_;
+                for $_.HOW.role_typecheck_list($_) {
+                    @!role_typecheck_list[+@!role_typecheck_list] := $_;
+                }
+            }
         }
 
         # Some things we only do if we weren't already composed once, like
@@ -92,8 +103,33 @@ class Perl6::Metamodel::ClassHOW
         $obj
     }
 
-    method does_list($obj) {
-        @!does_list
+    method roles($obj, :$local, :$transitive) {
+        my @result;
+        for @!roles {
+            @result.push($_);
+            if $transitive {
+                for $_.HOW.roles($_, :transitive(1)) {
+                    @result.push($_);
+                }
+            }
+        }
+        unless $local {
+            my $first := 1;
+            for self.mro($obj) {
+                if $first {
+                    $first := 0;
+                    next;
+                }
+                for $_.HOW.roles($_, :transitive($transitive), :local(1)) {
+                    @result.push($_);
+                }
+            }
+        }
+        @result
+    }
+
+    method role_typecheck_list($obj) {
+        @!role_typecheck_list
     }
 
     method is_composed($obj) {

diff --git a/src/Perl6/Metamodel/ConcreteRoleHOW.pm b/src/Perl6/Metamodel/ConcreteRoleHOW.pm
@@ -11,11 +11,12 @@ class Perl6::Metamodel::ConcreteRoleHOW
     # Any collisions to resolve.
     has @!collisions;
 
-    # The parametric role(s) that this concrete one was derived from.
-    has @!parametrics;
+    # The (parametric) role(s) that this concrete one was directly derived
+    # from.
+    has @!roles;
 
-    # Full flat list of "does" roles.
-    has @!does_list;
+    # Full flat list of done roles.
+    has @!role_typecheck_list;
 
     my $archetypes := Perl6::Metamodel::Archetypes.new( :nominal(1), :composable(1) );
     method archetypes() {
@@ -29,8 +30,8 @@ class Perl6::Metamodel::ConcreteRoleHOW
         method roles() { @!roles }
     }
 
-    method new_type(:@parametrics, :$name = '<anon>', :$ver, :$auth, :$repr) {
-        my $metarole := self.new(:parametrics(@parametrics), :name($name), :ver($ver), :auth($auth));
+    method new_type(:@roles, :$name = '<anon>', :$ver, :$auth, :$repr) {
+        my $metarole := self.new(:roles(@roles), :name($name), :ver($ver), :auth($auth));
         pir::repr_type_object_for__PPS($metarole, 'Uninstantiable');
     }
 
@@ -41,18 +42,56 @@ class Perl6::Metamodel::ConcreteRoleHOW
     }
 
     method compose($obj) {
-        @!does_list := RoleToRoleApplier.apply($obj, self.roles_to_compose($obj));
-        for @!parametrics {
-            @!does_list.push($_);
+        RoleToRoleApplier.apply($obj, self.roles_to_compose($obj));
+        for @!roles {
+            @!role_typecheck_list[+@!role_typecheck_list] := $_;
+            for $_.HOW.role_typecheck_list($_) {
+                @!role_typecheck_list[+@!role_typecheck_list] := $_;
+            }
         }
+        self.publish_type_cache($obj);
         $obj
     }
 
     method collisions($obj) {
         @!collisions
     }
 
-    method does_list($obj) {
-        @!does_list
+    method roles($obj, :$transitive) {
+        if $transitive {
+            my @trans;
+            for @!roles {
+                @trans.push($_);
+                for $_.HOW.roles($_) {
+                    @trans.push($_);
+                }
+            }
+        }
+        else {
+            @!roles
+        }
+    }
+
+    method role_typecheck_list($obj) {
+        @!role_typecheck_list
+    }
+
+    method type_check($obj, $checkee) {
+        my $decont := pir::perl6_decontainerize__PP($checkee);
+        if $decont =:= $obj.WHAT {
+            return 1;
+        }
+        for @!role_typecheck_list {
+            if pir::perl6_decontainerize__PP($_) =:= $decont {
+                return 1;
+            }
+        }
+        0
+    }
+
+    method publish_type_cache($obj) {
+        my @types := [$obj.WHAT];
+        for @!role_typecheck_list { @types.push($_) }
+        pir::publish_type_check_cache($obj, @types)
     }
 }
diff --git a/src/Perl6/Metamodel/CurriedRoleHOW.pm b/src/Perl6/Metamodel/CurriedRoleHOW.pm
@@ -42,4 +42,12 @@ class Perl6::Metamodel::CurriedRoleHOW
     method name($obj) {
         $!curried_role.HOW.name($!curried_role)
     }
+
+    method roles($obj, :$transitive) {
+        $!curried_role.HOW.roles($obj, :transitive($transitive))
+    }
+
+    method role_typecheck_list($obj) {
+        $!curried_role.HOW.role_typecheck_list($obj)
+    }
 }
diff --git a/src/Perl6/Metamodel/MROBasedTypeChecking.pm b/src/Perl6/Metamodel/MROBasedTypeChecking.pm
@@ -15,9 +15,8 @@ role Perl6::Metamodel::MROBasedTypeChecking {
             if $_ =:= $checkee {
                 return 1;
             }
-            if pir::can($_.HOW, 'does_list') {
-                my @does_list := $_.HOW.does_list($_);
-                for @does_list {
+            if pir::can($_.HOW, 'role_typecheck_list') {
+                for $_.HOW.role_typecheck_list($_) {
                     if $_ =:= $checkee {
                         return 1;
                     }
@@ -31,9 +30,8 @@ role Perl6::Metamodel::MROBasedTypeChecking {
         my @tc;
         for self.mro($obj) {
             @tc.push($_);
-            if pir::can($_.HOW, 'does_list') {
-                my @does_list := $_.HOW.does_list($_);
-                for @does_list {
+            if pir::can($_.HOW, 'role_typecheck_list') {
+                for $_.HOW.role_typecheck_list($_) {
                     @tc.push($_);
                 }
             }

diff --git a/src/Perl6/Metamodel/ParametricRoleHOW.pm b/src/Perl6/Metamodel/ParametricRoleHOW.pm
@@ -15,6 +15,7 @@ class Perl6::Metamodel::ParametricRoleHOW
 {
     has $!composed;
     has $!body_block;
+    has @!role_typecheck_list;
 
     my $archetypes := Perl6::Metamodel::Archetypes.new( :nominal(1), :composable(1), :inheritalizable(1), :parametric(1) );
     method archetypes() {
@@ -35,6 +36,14 @@ class Perl6::Metamodel::ParametricRoleHOW
     }
 
     method compose($obj) {
+        my @rtl;
+        for self.roles_to_compose($obj) {
+            @rtl.push($_);
+            for $_.HOW.role_typecheck_list($_) {
+                @rtl.push($_);
+            }
+        }
+        @!role_typecheck_list := @rtl;
         $!composed := 1;
         $obj
     }
@@ -43,12 +52,33 @@ class Perl6::Metamodel::ParametricRoleHOW
         $!composed
     }
 
+    method roles($obj, :$transitive) {
+        if $transitive {
+            my @result;
+            for self.roles_to_compose($obj) {
+                @result.push($_);
+                for $_.HOW.roles($_, :transitive(1)) {
+                    @result.push($_)
+                }
+            }
+            @result
+        }
+        else {
+            self.roles_to_compose($obj)
+        }
+    }
+
+    method role_typecheck_list($obj) {
+        @!role_typecheck_list
+    }
+
     method type_check($obj, $checkee) {
-        if $obj =:= $checkee {
+        my $decont := pir::perl6_decontainerize__PP($checkee);
+        if $decont =:= $obj.WHAT {
             return 1;
         }
         for self.prentending_to_be() {
-            if $checkee =:= $_ {
+            if $decont =:= pir::perl6_decontainerize__PP($_) {
                 return 1;
             }
         }
@@ -75,7 +105,7 @@ class Perl6::Metamodel::ParametricRoleHOW
         }
 
         # Create a concrete role.
-        my $conc := $concrete.new_type(:parametrics([$obj]), :name(self.name($obj)));
+        my $conc := $concrete.new_type(:roles([$obj]), :name(self.name($obj)));
 
         # Go through attributes, reifying as needed and adding to
         # the concrete role.

diff --git a/src/Perl6/Metamodel/RoleToClassApplier.pm b/src/Perl6/Metamodel/RoleToClassApplier.pm
@@ -84,6 +84,6 @@ my class RoleToClassApplier {
             $target.HOW.add_attribute($target, $_);
         }
 
-        return $to_compose_meta.does_list($to_compose);
+        1;
     }
 }
diff --git a/src/Perl6/Metamodel/RoleToRoleApplier.pm b/src/Perl6/Metamodel/RoleToRoleApplier.pm
@@ -70,7 +70,6 @@ my class RoleToRoleApplier {
         }
 
         # Now do the other bits.
-        my @all_roles;
         for @roles {
             my $how := $_.HOW;
 
@@ -103,14 +102,8 @@ my class RoleToRoleApplier {
                     $target.HOW.add_multi_method($target, $_.name, $_.code);
                 }
             }
-
-            # Build up full list of roles that this one does.
-            @all_roles.push($_);
-            for $how.does_list($_) {
-                @all_roles.push($_);
-            }
         }
 
-        return @all_roles;
+        1;
     }
 }