Skip to content
Permalink
Browse files

Merge pull request #2715 from vrurg/issue_2698

Fix for #2698
  • Loading branch information...
vrurg committed May 23, 2019
2 parents 82b4daa + 9c6fa1e commit 0023f64cf6d13022e66fb10a9e2b9515f89a502c
Showing with 108 additions and 15 deletions.
  1. +103 −14 src/Perl6/Metamodel/CurriedRoleHOW.nqp
  2. +5 −1 src/Perl6/Metamodel/ParametricRoleGroupHOW.nqp
@@ -19,28 +19,37 @@ class Perl6::Metamodel::CurriedRoleHOW
does Perl6::Metamodel::RolePunning
does Perl6::Metamodel::TypePretense
does Perl6::Metamodel::Naming
does Perl6::Metamodel::RoleContainer
{
has $!curried_role;
has @!pos_args;
has %!named_args;
has @!role_typecheck_list;
has $!is_complete;
has $!archetypes;

my $archetypes_g := Perl6::Metamodel::Archetypes.new( :composable(1), :inheritalizable(1), :parametric(1), :generic(1) );
my $archetypes_ng := Perl6::Metamodel::Archetypes.new( :nominal(1), :composable(1), :inheritalizable(1), :parametric(1) );
method archetypes() {
if nqp::isconcrete(self) {
for @!pos_args {
if $_.HOW.archetypes.generic {
return $archetypes_g;
}
method !choose_archetype() {
for @!pos_args {
if $_.HOW.archetypes.generic {
return $archetypes_g;
}
for %!named_args {
if $_.value.HOW.archetypes.generic {
return $archetypes_g;
}
}
for %!named_args {
if $_.value.HOW.archetypes.generic {
return $archetypes_g;
}
}
$archetypes_ng
}
method archetypes() {
if nqp::isconcrete(self) {
$!archetypes := self.'!choose_archetype'() unless $!archetypes;
return $!archetypes;
}
$archetypes_ng
}

method new(*%named) {
nqp::findmethod(NQPMu, 'BUILDALL')(nqp::create(self), |%named)
@@ -60,7 +69,52 @@ 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)
nqp::settypecheckmode($type, 2);
}

method parameterize_roles($obj) {
my @pos_args;
nqp::push(@pos_args, $obj);
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($_.HOW, 'curried_role') && $_.HOW.archetypes.generic && $type_env {
$role := $_.HOW.instantiate_generic($_, $type_env);
}
self.add_role($obj, $role);
}
self.update_role_typecheck_list($obj);
}

method update_role_typecheck_list($obj) {
my @rtl;
nqp::push(@rtl, $!curried_role);
# XXX Not sure if it makes sense adding roles from group into the type checking.
# for $!curried_role.HOW.role_typecheck_list($obj) {
# nqp::push(@rtl, $_);
# }
for self.roles_to_compose($obj) {
nqp::push(@rtl, $_);
for $_.HOW.role_typecheck_list($_) {
nqp::push(@rtl, $_);
}
}
@!role_typecheck_list := @rtl;
}

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

method instantiate_generic($obj, $type_env) {
@@ -92,16 +146,51 @@ class Perl6::Metamodel::CurriedRoleHOW
@!pos_args
}

# method roles($obj, :$transitive = 1) {
# $!curried_role.HOW.roles($obj, :$transitive)
# }

method roles($obj, :$transitive = 1) {
$!curried_role.HOW.roles($obj, :$transitive)
self.complete_parameterization($obj);
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) {
$!curried_role.HOW.role_typecheck_list($obj)
self.complete_parameterization($obj);
@!role_typecheck_list
}

method type_check($obj, $checkee) {
$!curried_role.HOW.type_check($!curried_role, $checkee)
my $decont := nqp::decont($checkee);
if $decont =:= $obj.WHAT {
return 1;
}
if $decont =:= $!curried_role {
return 1;
}
for self.pretending_to_be() {
if $decont =:= nqp::decont($_) {
return 1;
}
}
for @!role_typecheck_list {
if $decont =:= nqp::decont($_) {
return 1;
}
}
0
}

method accepts_type($obj, $checkee) {
@@ -93,7 +93,7 @@ class Perl6::Metamodel::ParametricRoleGroupHOW
self.update_role_typecheck_list($obj);
}

method specialize($obj, *@pos_args, *%named_args) {
method select_candidate($obj, @pos_args, %named_args) {
# Use multi-dispatcher to pick the body block of the best role.
my $error;
my $selected_body;
@@ -125,7 +125,11 @@ class Perl6::Metamodel::ParametricRoleGroupHOW
if $selected =:= NQPMu {
nqp::die("Internal error: could not resolve body block to role candidate");
}
$selected
}

method specialize($obj, *@pos_args, *%named_args) {
my $selected := self.select_candidate($obj, @pos_args, %named_args);
# Having picked the appropriate one, specialize it.
$selected.HOW.specialize($selected, |@pos_args, |%named_args);
}

0 comments on commit 0023f64

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