Skip to content
Permalink
Browse files

Merge pull request #2717 from vrurg/issue_2714

Fix for #2714

This fix would make a role pass typechecking against its parent classes.

It is also changes the default logic of Metamodel::ParametricRoleGroupHOW with regard to its assumed default role for introspection. Where previously it was the first candidate it would now use a non-signatured role if such exists and only fall back to the first candidate otherwise.
  • Loading branch information...
vrurg committed Jun 19, 2019
2 parents 8ddc2ad + 5f6c1ba commit 6c02354633aec4f1ef146c7adb487397b4c4902b
@@ -22,6 +22,7 @@ class Perl6::Metamodel::CurriedRoleHOW
does Perl6::Metamodel::RoleContainer
{
has $!curried_role;
has $!candidate; # Will contain matching candidate from curried role group
has @!pos_args;
has %!named_args;
has @!role_typecheck_list;
@@ -69,6 +70,7 @@ class Perl6::Metamodel::CurriedRoleHOW
my $meta := self.new(:curried_role($curried_role), :pos_args(@pos_args),
:named_args(%named_args), :name($name));
my $type := nqp::settypehll(nqp::newtype($meta, 'Uninstantiable'), 'perl6');

nqp::settypecheckmode($type, 2);
}

@@ -78,17 +80,19 @@ class Perl6::Metamodel::CurriedRoleHOW
for @!pos_args {
nqp::push(@pos_args, $_);
}
my $candidate := $!curried_role.HOW.select_candidate($!curried_role, @pos_args, %!named_args);
my $type_env;
try {
my @result := $candidate.HOW.body_block($candidate)(|@pos_args, |%!named_args);
$type_env := @result[1];
}
for $candidate.HOW.roles($candidate, :!transitive) -> $role {
if nqp::can($role.HOW, 'curried_role') && $role.HOW.archetypes.generic && $type_env {
$role := $role.HOW.instantiate_generic($role, $type_env);
if nqp::istype($!curried_role.HOW, Perl6::Metamodel::ParametricRoleGroupHOW) {
$!candidate := $!curried_role.HOW.select_candidate($!curried_role, @pos_args, %!named_args);
my $type_env;
try {
my @result := $!candidate.HOW.body_block($!candidate)(|@pos_args, |%!named_args);
$type_env := @result[1];
}
for $!candidate.HOW.roles($!candidate, :!transitive) -> $role {
if nqp::can($role.HOW, 'curried_role') && $role.HOW.archetypes.generic && $type_env {
$role := $role.HOW.instantiate_generic($role, $type_env);
}
self.add_role($obj, $role);
}
self.add_role($obj, $role);
}
self.update_role_typecheck_list($obj);
}
@@ -111,9 +115,9 @@ class Perl6::Metamodel::CurriedRoleHOW

method complete_parameterization($obj) {
unless $!is_complete {
$!is_complete := 1;
self.parameterize_roles($obj);
self.update_role_typecheck_list($obj);
$!is_complete := 1;
}
}

@@ -185,8 +189,16 @@ class Perl6::Metamodel::CurriedRoleHOW
return 1;
}
}
self.complete_parameterization($obj) unless $!is_complete;
if !($!candidate =:= NQPMu) && $!candidate.HOW.type_check_parents($!candidate, $decont) {
return 1
}
for @!role_typecheck_list {
if $decont =:= nqp::decont($_) {
my $dr := nqp::decont($_);
if $decont =:= $dr {
return 1;
}
if nqp::istype($dr, $decont) {
return 1;
}
}
@@ -21,6 +21,7 @@ class Perl6::Metamodel::ParametricRoleGroupHOW
has @!candidates;
has $!selector;
has @!role_typecheck_list;
has @!nonsignatured;

my $archetypes := Perl6::Metamodel::Archetypes.new( :nominal(1), :composable(1), :inheritalizable(1), :parametric(1) );
method archetypes() {
@@ -89,6 +90,7 @@ class Perl6::Metamodel::ParametricRoleGroupHOW

method add_possibility($obj, $possible) {
@!candidates[+@!candidates] := $possible;
nqp::push(@!nonsignatured, nqp::decont($possible)) unless $possible.HOW.signatured($possible);
$!selector.add_dispatchee($possible.HOW.body_block($possible));
self.update_role_typecheck_list($obj);
}
@@ -135,11 +137,8 @@ class Perl6::Metamodel::ParametricRoleGroupHOW
}

method update_role_typecheck_list($obj) {
for @!candidates {
if !$_.HOW.signatured($_) {
@!role_typecheck_list := $_.HOW.role_typecheck_list($_);
}
}
my $ns := self.'!get_nonsignatured_candidate'($obj);
@!role_typecheck_list := $ns.HOW.role_typecheck_list($ns) unless nqp::isnull($ns);
}

method role_typecheck_list($obj) {
@@ -161,6 +160,8 @@ class Perl6::Metamodel::ParametricRoleGroupHOW
return 1;
}
}
my $ns := self.'!get_nonsignatured_candidate'($obj);
return $ns.HOW.type_check_parents($ns, $decont) unless nqp::isnull($ns);
0;
}

@@ -197,6 +198,11 @@ class Perl6::Metamodel::ParametricRoleGroupHOW
}

method !get_default_candidate($obj) {
@!candidates[0]
self.'!get_nonsignatured_candidate'($obj) || @!candidates[0]
}

method !get_nonsignatured_candidate($obj) {
return nqp::null unless +@!nonsignatured;
@!nonsignatured[0]
}
}
@@ -114,6 +114,16 @@ class Perl6::Metamodel::ParametricRoleHOW
@!role_typecheck_list
}

# $checkee must always be decont'ed
method type_check_parents($obj, $checkee) {
for self.parents($obj, :local) -> $parent {
if nqp::istype($checkee, $parent) {
return 1;
}
}
0
}

method type_check($obj, $checkee) {
my $decont := nqp::decont($checkee);
if $decont =:= $obj.WHAT {
@@ -128,11 +138,11 @@ class Perl6::Metamodel::ParametricRoleHOW
}
}
for self.roles_to_compose($obj) {
if nqp::istype($checkee, $_) {
if nqp::istype($decont, $_) {
return 1;
}
}
0
self.type_check_parents($obj, $decont);
}

method specialize($obj, *@pos_args, *%named_args) {

0 comments on commit 6c02354

Please sign in to comment.
You can’t perform that action at this time.