Skip to content

Commit

Permalink
Streamline Metamodel::CoercionHOW
Browse files Browse the repository at this point in the history 
- add a proper .new method
- add some more attributes to be set on class creation
- simplify new-type logic
- simplify instantiate_generic logic
- simplify coercion logic a bit
- simplify parameterization logic
  • Loading branch information
@lizmat
lizmat committed Mar 13, 2024
1 parent 9d7a4c2 commit b83e6fa
Showing 1 changed file with 121 additions and 88 deletions.
209 changes: 121 additions & 88 deletions src/Perl6/Metamodel/CoercionHOW.nqp
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
#- Metamodel::CoercionHOW ------------------------------------------------------
# Coercion types, of the form TargetType(ConstraintType), are implemented with
# 6model parametrics. We create a single BEGIN-time "root" for the coercion
# type family, and the target and constraint types are stored as parameters.
Expand All @@ -8,85 +9,100 @@ class Perl6::Metamodel::CoercionHOW
does Perl6::Metamodel::LanguageRevision
does Perl6::Metamodel::Nominalizable
{
has $!target_type;
has $!nominal_target;
has $!constraint_type;
has $!archetypes;

method archetypes($XXX?) {
unless nqp::isconcrete($!archetypes) {
my $generic :=
$!target_type.HOW.archetypes($!target_type).generic
|| $!constraint_type.HOW.archetypes($!constraint_type).generic;
$!archetypes := Perl6::Metamodel::Archetypes.new(
:coercive, :nominalizable, :$generic,
definite => $!target_type.HOW.archetypes($!target_type).definite );
}
$!archetypes
}
has $!target_type;
has $!constraint_type;
has $!nominal_target;
has $!archetypes;
has int $!target_type_generic;
has int $!constraint_type_generic;
has str $!name;
has str $!shortname;

method new_type($target, $constraint) {
my $coercion_type := nqp::parameterizetype((Perl6::Metamodel::CoercionHOW.WHO)<root>,
[$target, $constraint]);
nqp::setdebugtypename($coercion_type, $coercion_type.HOW.name($coercion_type));
$coercion_type
}
method new(:$target_type!, :$constraint_type!) {
my $obj := nqp::create(self);

method set_target_type($target_type) {
$!target_type := $target_type;
$!nominal_target := $!target_type.HOW.archetypes($!target_type).nominalizable
?? $!target_type.HOW.nominalize($!target_type)
!! $!target_type;
}
my int $target_type_generic :=
$target_type.HOW.archetypes($target_type).generic;
my int $constraint_type_generic :=
$constraint_type.HOW.archetypes($constraint_type).generic;

method set_constraint_type($constraint_type) {
$!constraint_type := $constraint_type;
}
nqp::bindattr($obj, Perl6::Metamodel::CoercionHOW, '$!target_type',
$target_type);
nqp::bindattr($obj, Perl6::Metamodel::CoercionHOW, '$!constraint_type',
$constraint_type);
nqp::bindattr($obj, Perl6::Metamodel::CoercionHOW, '$!nominal_target',
$target_type.HOW.archetypes($target_type).nominalizable
?? $target_type.HOW.nominalize($target_type)
!! $target_type);
nqp::bindattr_i($obj, Perl6::Metamodel::CoercionHOW,
'$!target_type_generic', $target_type_generic
);
nqp::bindattr_i($obj, Perl6::Metamodel::CoercionHOW,
'$!constraint_type_generic', $constraint_type_generic
);
nqp::bindattr($obj, Perl6::Metamodel::CoercionHOW, '$!archetypes',
Perl6::Metamodel::Archetypes.new(
:coercive,
:nominalizable,
:generic($target_type_generic || $constraint_type_generic),
:definite($target_type.HOW.archetypes($target_type).definite)
));
nqp::bindattr_s($obj, Perl6::Metamodel::CoercionHOW, '$!name',
$target_type.HOW.name($target_type)
~ '(' ~ $constraint_type.HOW.name($constraint_type) ~ ')'
);
nqp::bindattr_s($obj, Perl6::Metamodel::CoercionHOW, '$!shortname',
$target_type.HOW.shortname($target_type)
~ '(' ~ $constraint_type.HOW.shortname($constraint_type) ~ ')'
);

method name($coercion_type) {
$!target_type.HOW.name($!target_type) ~ '(' ~ $!constraint_type.HOW.name($!constraint_type) ~ ')'
$obj
}

method shortname($coercion_type) {
$!target_type.HOW.shortname($!target_type) ~ '(' ~ $!constraint_type.HOW.shortname($!constraint_type) ~ ')'
}
method target_type( $XXX?) { $!target_type }
method constraint_type($XXX?) { $!constraint_type }
method nominal_target( $XXX?) { $!nominal_target }
method archetypes( $XXX?) { $!archetypes }
method name( $XXX?) { $!name }
method shortname( $XXX?) { $!shortname }

method target_type($coercion_type) {
$!target_type
method new_type($target, $constraint) {
nqp::parameterizetype(
nqp::atkey(Perl6::Metamodel::CoercionHOW.WHO, 'root'),
nqp::list($target, $constraint)
)
}

method constraint_type($coercion_type) {
$!constraint_type
method nominalize($coercion_type) {
my $target_type := $!target_type;
$target_type.HOW.archetypes($target_type).nominalizable
?? $target_type.HOW.nominalize($target_type)
!! $target_type
}

method nominal_target($coercion_type) {
$!nominal_target
}
method instantiate_generic($coercion, $type_env) {
if $!target_type_generic || $!constraint_type_generic {
my $target := $!target_type;
my $constraint := $!constraint_type;

method nominalize($coercion_type) {
$!target_type.HOW.archetypes($!target_type).nominalizable
?? $!target_type.HOW.nominalize($!target_type)
!! $!target_type
}
$target := $target.HOW.instantiate_generic($target, $type_env)
if $!target_type_generic;
$constraint :=
$constraint.HOW.instantiate_generic($constraint, $type_env)
if $!constraint_type_generic;

method instantiate_generic($coercion_type, $type_env) {
return $coercion_type unless self.archetypes.generic;
my $ins_target :=
$!target_type.HOW.archetypes($!target_type).generic
?? $!target_type.HOW.instantiate_generic($!target_type, $type_env)
!! $!target_type;
my $ins_constraint :=
$!constraint_type.HOW.archetypes($!constraint_type).generic
?? $!constraint_type.HOW.instantiate_generic($!constraint_type, $type_env)
!! $!constraint_type;
self.new_type($ins_target, $ins_constraint);
self.new_type($target, $constraint)
}
else {
$coercion
}
}

method find_method($coercion_type, $name, *%c) {
method find_method($XXX, $name, *%c) {
$!target_type.HOW.find_method($!target_type, $name, |%c)
}

method find_method_qualified($coercion_type, $qtype, $name) {
method find_method_qualified($XXX, $qtype, $name) {
$!target_type.HOW.find_method_qualified($!target_type, $qtype, $name)
}

Expand All @@ -99,12 +115,13 @@ class Perl6::Metamodel::CoercionHOW
}

method type_check($coercion_type, $checkee) {
$coercion_type =:= $checkee
nqp::eqaddr($coercion_type, $checkee)
|| $!target_type.HOW.type_check($!target_type, $checkee);
}

method accepts_type($coercion_type, $checkee) {
nqp::istype($checkee, $!target_type) || nqp::istype($checkee, $!constraint_type);
nqp::istype($checkee, $!target_type)
|| nqp::istype($checkee, $!constraint_type);
}

# Coercion protocol method.
Expand All @@ -121,20 +138,27 @@ class Perl6::Metamodel::CoercionHOW

# Attempt coercion on TargetType
method !coerce_TargetType($target, $value) {
my $constraintHOW := $!constraint_type.HOW;
$value := $constraintHOW.coerce($!constraint_type, $value)
if $constraintHOW.archetypes($!constraint_type).coercive;
my $constraint_type := $!constraint_type;
my $constraintHOW := $constraint_type.HOW;

$value := $constraintHOW.coerce($constraint_type, $value)
if $constraintHOW.archetypes($constraint_type).coercive;

my $nominal_target := $!nominal_target;
nqp::istype($value, $!constraint_type)
nqp::istype($value, $constraint_type)
?? nqp::defined(
my $method := nqp::tryfindmethod(
nqp::what($value),
$nominal_target.HOW.name($nominal_target)))
?? (nqp::istype((my $coerced := $method($value)),$!target_type)
|| nqp::istype($coerced, nqp::gethllsym('Raku', 'Failure')))
$nominal_target.HOW.name($nominal_target)
)
)
?? (nqp::istype((my $coerced := $method($value)), $!target_type)
|| nqp::istype($coerced, nqp::gethllsym('Raku', 'Failure'))
)
?? $coerced
!! self."!invalid_coercion"($value, $nominal_target.HOW.name($nominal_target), $coerced)
!! self."!invalid_coercion"(
$value, $nominal_target.HOW.name($nominal_target), $coerced
)
!! self."!coerce_COERCE"($target, $value, $nominal_target)
!! self."!invalid_type"($value)
}
Expand Down Expand Up @@ -205,11 +229,12 @@ class Perl6::Metamodel::CoercionHOW
my $method := nqp::tryfindmethod($nominal_target, 'new')
) && nqp::can($method, 'cando')
&& $method.cando($nominal_target, $value) {

# There should be no significant performance penalty on this path
# because if method call ever throws then this is going to result
# in an exception one way or another.
my $exception;
my $coerced_value := nqp::null();
my $coerced_value := nqp::null;
try {
CATCH {
my $exception_obj := nqp::getpayload($!);
Expand All @@ -228,39 +253,47 @@ class Perl6::Metamodel::CoercionHOW
if nqp::istype($coerced_value, $!target_type)
|| nqp::istype(
$coerced_value,
nqp::gethllsym('Raku', 'Failure') )
nqp::gethllsym('Raku', 'Failure')
)
}

if nqp::defined($exception) {
nqp::rethrow($exception);
}
elsif !nqp::isnull($coerced_value) {
elsif nqp::not_i(nqp::isnull($coerced_value)) {
self."!invalid_coercion"($value, 'new', $coerced_value)
}
}

self."!invalid"($value, "no acceptable coercion method found")
}

# Methods needed by Perl6::Metamodel::Nominalizable
method nominalizable_kind() { 'coercion' }
method !wrappee($XXX?) { $!target_type }
}

BEGIN {
my $root := nqp::newtype(Perl6::Metamodel::CoercionHOW.new, 'Uninstantiable');
my $root := nqp::newtype(Perl6::Metamodel::CoercionHOW, 'Uninstantiable');
nqp::settypehll($root, 'Raku');
nqp::setdebugtypename(nqp::settypehll($root, 'Raku'), 'CoercionHOW root');
nqp::setparameterizer($root, sub ($type, $params) {
my $metaclass := $type.HOW.new();
$metaclass.set_target_type($params[0]);
$metaclass.set_constraint_type($params[1]);
my $coercion_type := nqp::settypehll(nqp::newtype($metaclass, 'Uninstantiable'), 'Raku');
$metaclass.set_language_version($coercion_type, :force);
nqp::settypecheckmode(
$coercion_type,
nqp::const::TYPE_CHECK_NEEDS_ACCEPTS
);
$coercion_type
nqp::setdebugtypename($root, 'CoercionHOW root');
nqp::setparameterizer(
$root,
sub ($type, $params) {
my $HOW := $type.HOW.new(
:target_type( nqp::atpos($params, 0)),
:constraint_type(nqp::atpos($params, 1))
);
my $coercion := nqp::newtype($HOW, 'Uninstantiable');
nqp::settypehll($coercion, 'Raku');
$HOW.set_language_version($coercion, :force);
nqp::setdebugtypename($coercion, $coercion.HOW.name($coercion));
nqp::settypecheckmode(
$coercion, nqp::const::TYPE_CHECK_NEEDS_ACCEPTS
);
$coercion
});
(Perl6::Metamodel::CoercionHOW.WHO)<root> := $root;
nqp::bindkey(Perl6::Metamodel::CoercionHOW.WHO, 'root', $root);
}

# vim: expandtab sw=4

0 comments on commit b83e6fa

Please sign in to comment.