From b83e6fa510d2160f61ef63657566645f78fc95ca Mon Sep 17 00:00:00 2001 From: Elizabeth Mattijsen Date: Thu, 14 Mar 2024 00:42:22 +0100 Subject: [PATCH] Streamline Metamodel::CoercionHOW - 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 --- src/Perl6/Metamodel/CoercionHOW.nqp | 209 ++++++++++++++++------------ 1 file changed, 121 insertions(+), 88 deletions(-) diff --git a/src/Perl6/Metamodel/CoercionHOW.nqp b/src/Perl6/Metamodel/CoercionHOW.nqp index 8629ef2319..0abe8656b8 100644 --- a/src/Perl6/Metamodel/CoercionHOW.nqp +++ b/src/Perl6/Metamodel/CoercionHOW.nqp @@ -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. @@ -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), - [$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) } @@ -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. @@ -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) } @@ -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($!); @@ -228,15 +253,18 @@ 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") } @@ -244,23 +272,28 @@ class Perl6::Metamodel::CoercionHOW 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; + nqp::bindkey(Perl6::Metamodel::CoercionHOW.WHO, 'root', $root); } # vim: expandtab sw=4