Skip to content

Commit

Permalink
Implement RakuAST::Type::Subset
Browse files Browse the repository at this point in the history 
This patch covers the following subset cases, which is understood to be
comprehensive:

- subset F where 5                      # subset with expression
- subset F where /5/                    # subset with a regex
- subset F where { $_ == 5 }            # subset with code block
- subset F where * ~~ 5                 # subset with WhateverCode
- subset M::F where 5                   # subset with subbed package
- module M { subset F where 5 }         # 'our' scoped, M::F available
- module M { my subset F where 5 }      # 'my' scoped, M::F unavailable
- class F::C {}; subset F where 5       # subset "steals" .WHO from F
  • Loading branch information
@ab5tract
ab5tract committed Feb 12, 2023
1 parent e39a546 commit c17d5b2
Show file tree
Hide file tree
Showing 5 changed files with 292 additions and 0 deletions.
4 changes: 4 additions & 0 deletions src/Perl6/Metamodel/SubsetHOW.nqp
View file
Expand Up @@ -71,6 +71,10 @@ class Perl6::Metamodel::SubsetHOW
}
}

method set_where($obj, $refinement) {
$!refinement := nqp::decont($refinement)
}

method refinee($obj) {
$!refinee
}
Expand Down
11 changes: 11 additions & 0 deletions src/Raku/Actions.nqp
View file
Expand Up @@ -1708,6 +1708,17 @@ class Raku::Actions is HLL::Actions does Raku::CommonActions {
self.attach: $/, $decl;
}

method type_declarator:sym<subset>($/) {
my $decl := self.r('Type', 'Subset').new(
:name($<longname>.ast),
:where($<EXPR>.ast),
:traits($<trait>),
:scope($*SCOPE)
);
$decl.IMPL-CHECK($*R, $*CU.context, 1);
self.attach: $/, $decl;
}

method trait($/) {
my $trait := $<trait_mod>.ast;
if $trait { # is repr(...) won't be handled as a trait
Expand Down
16 changes: 16 additions & 0 deletions src/Raku/Grammar.nqp
View file
Expand Up @@ -2240,6 +2240,22 @@ grammar Raku::Grammar is HLL::Grammar does Raku::Common {
[ <.ws> <term_init=initializer> || <.typed_panic: "X::Syntax::Term::MissingInitializer"> ]
}
rule type_declarator:sym<subset> {
:my $*IN_DECL := 'subset';
<sym><.kok>
[
[
[
<longname>
]
{ $*IN_DECL := '' }
<trait>*
[ where <EXPR('e=')> ]?
]
|| <.malformed('subset')>
]
}
rule trait($*TARGET?) {
:my $*IN_DECL := '';
<trait_mod>
Expand Down
20 changes: 20 additions & 0 deletions src/Raku/ast/signature.rakumod
View file
Expand Up @@ -503,6 +503,9 @@ class RakuAST::Parameter
if nqp::defined($!value) {
nqp::push(@post_constraints, $!value);
}
if nqp::defined($!type) && $!type.meta-object.HOW.archetypes.nominalizable {
nqp::push(@post_constraints, $!type.meta-object);
}
if nqp::elems(@post_constraints) {
nqp::bindattr($parameter, Parameter, '@!post_constraints', @post_constraints);
}
Expand Down Expand Up @@ -959,6 +962,23 @@ class RakuAST::Parameter
);
}

# Take care of checking against provided subset types and other nominalizable types.
# TODO: Investigate breakage -- No such method 'ACCEPTS' for invocant of type '::?CLASS:D'
# if nqp::defined($!type) && $!type.meta-object.HOW.archetypes.nominalizable {
if nqp::defined($!type) && nqp::istype($!type.meta-object.HOW, Perl6::Metamodel::SubsetHOW) {
my $type-object := $!type.meta-object;
$context.ensure-sc($type-object);
$param-qast.push(
QAST::ParamTypeCheck.new(
QAST::Op.new(
:op('callmethod'), :name('ACCEPTS'),
QAST::WVal.new( :value($type-object) ),
$temp-qast-var
)
)
);
}

@prepend ?? QAST::Stmts.new( |@prepend, $param-qast ) !! $param-qast
}
}
Expand Down
241 changes: 241 additions & 0 deletions src/Raku/ast/type.rakumod
View file
Expand Up @@ -310,3 +310,244 @@ class RakuAST::Type::Parameterized
False
}
}

class RakuAST::Type::Subset
is RakuAST::Type
is RakuAST::Declaration
is RakuAST::BeginTime
is RakuAST::TraitTarget
is RakuAST::StubbyMeta
is RakuAST::Attaching
{
has RakuAST::Name $.name;
has RakuAST::Expression $.where;
has RakuAST::Declaration $.of;
has RakuAST::Package $!current-package;

method new(RakuAST::Name :$name, RakuAST::Expression :$where, List :$traits, str :$scope) {
my $obj := nqp::create(self);
nqp::bindattr($obj, RakuAST::Type::Subset, '$!name', $name);
nqp::bindattr($obj, RakuAST::Type::Subset, '$!where', $where);
nqp::bindattr_s($obj, RakuAST::Declaration, '$!scope', $scope);
for $obj.IMPL-UNWRAP-LIST($traits) {
$obj.add-trait($_.ast);
}
$obj
}

method default-scope() { 'our' }

method allowed-scopes() { self.IMPL-WRAP-LIST(['my', 'our']) }

method lexical-name() { $!name.canonicalize }

method generate-lookup() {
my $lookup := RakuAST::Term::Name.new($!name);
$lookup.set-resolution(self);
$lookup
}

method visit-children(Code $visitor) {
$visitor($!name);
$visitor($!where);
# External constants break if visited with missing IMPL-QAST-DECL. Adding a sensible IMPL-QAST-DECL
# results in lexical declarations for things like Int, which will break if added more than once.
$visitor($!of) if $!of && !nqp::istype($!of, RakuAST::Declaration::External::Constant);
# Below fails with No such method 'apply-sink' for invocant of type 'GLOBALish'
#$visitor($!current-package);
}

method is-lexical() { True }
method is-simple-lexical-declaration() { False }

method attach(RakuAST::Resolver $resolver) {
nqp::bindattr(self, RakuAST::Type::Subset, '$!current-package', $resolver.current-package);
}

method IMPL-EXPR-QAST(RakuAST::IMPL::QASTContenxt $context) {
my $value := self.meta-object;
$context.ensure-sc($value);
QAST::WVal.new( :$value )
}

method IMPL-INSTALL-SUBSET(RakuAST::Resolver $resolver, RakuAST::Name $name, Mu $type-object) {
my str $scope := self.scope;
my $target;
my $final;
my $lexical;
my $lexically-registered;
if $name.is-identifier {
$final := $name.canonicalize;
$lexical := $resolver.resolve-lexical-constant($final);

# If the subset shares the name of a stubbed package, it will have resolved via the above.
if !$lexical {
$resolver.current-scope.merge-generated-lexical-declaration:
# TODO: Using Implicit::Constant because it had the right type signature/QAST output
RakuAST::VarDeclaration::Implicit::Constant.new:
:name($final),
:value($type-object),
:scope($scope);
}
$lexically-registered := True;

# If `our`-scoped, also put it into the current package.
if $scope eq 'our' {
# TODO conflicts
$target := $!current-package;
}
} else {
my @parts := nqp::clone(self.IMPL-UNWRAP-LIST($name.parts));
$final := nqp::pop(@parts).name;
my $resolved := $resolver.partially-resolve-name-constant(RakuAST::Name.new(|@parts));

if $resolved { # first parts of the name found
$resolved := self.IMPL-UNWRAP-LIST($resolved);
$target := $resolved[0];
my $parts := $resolved[1];
my @parts := self.IMPL-UNWRAP-LIST($parts);
$scope := 'our'; # Ensure we install the package into the parent stash
if nqp::elems(@parts) {
my $longname := $target.HOW.name($target);

for @parts {
$longname := $longname ~ '::' ~ $_.name;
my $package := Perl6::Metamodel::PackageHOW.new_type(name => $longname);
$package.HOW.compose($package);
my %stash := $resolver.IMPL-STASH-HASH($target);
%stash{$_.name} := $package;
$target := $package;
}
}
} else {
my $first := nqp::shift(@parts).name;
$target := Perl6::Metamodel::PackageHOW.new_type(name => $first);
$target.HOW.compose($target);

$resolver.current-scope.merge-generated-lexical-declaration:
RakuAST::Declaration::LexicalPackage.new:
:lexical-name($first),
:compile-time-value($target),
:package($!current-package);
if $scope eq 'our' {
# TODO conflicts
my %stash := $resolver.IMPL-STASH-HASH($!current-package);
%stash{$first} := $target;
}
$scope := 'our'; # Ensure we install the package into the generated stub

my $longname := $first;
for @parts {
$longname := $longname ~ '::' ~ $_.name;
my $package := Perl6::Metamodel::PackageHOW.new_type(name => $longname);
$package.HOW.compose($package);
my %stash := $resolver.IMPL-STASH-HASH($target);
%stash{$_.name} := $package;
$target := $package;
}
}
$lexical := $resolver.resolve-lexical-constant($final);
}

my %stash := $resolver.IMPL-STASH-HASH($target);
# upgrade a lexically imported package stub to package scope if it exists
if $lexical {
%stash{$final} := $lexical.compile-time-value;
}

# Take care of installing in case we had to make or find packages
if !$lexically-registered {
$resolver.current-scope.merge-generated-lexical-declaration:
#TODO: Using Implicit::Constant because it had the right type signature/QAST output combination
RakuAST::VarDeclaration::Implicit::Constant.new:
:name($final),
:value($type-object),
:scope($scope);
}

if $scope eq 'our' {
if nqp::existskey(%stash, $final) {
nqp::setwho($type-object, %stash{$final}.WHO);
}
%stash{$final} := $type-object;
}
}

method is-begin-performed-after-children() { True }

method PERFORM-BEGIN-AFTER-CHILDREN(RakuAST::Resolver $resolver, RakuAST::IMPL::QASTContext $context) {
self.apply-traits($resolver, $context, self);

for self.IMPL-UNWRAP-LIST(self.traits) {
if nqp::istype($_, RakuAST::Trait::Of) {
if $!of {
nqp::die("Cannot declare more than one 'of' trait per subset");
}
my $of-type := $resolver.resolve-name-constant($_.type.name);
nqp::bindattr(self, RakuAST::Type::Subset, '$!of', $of-type);
}
}

my $block;
if !$!where.IMPL-CURRIED && (!nqp::istype($!where, RakuAST::Code) || nqp::istype($!where, RakuAST::RegexThunk)) {
$block := RakuAST::Block.new(
body => RakuAST::Blockoid.new(
RakuAST::StatementList.new(
RakuAST::Statement::Expression.new(
expression => RakuAST::ApplyPostfix.new(
operand => RakuAST::ApplyPostfix.new(
operand => $!where,
postfix => RakuAST::Call::Method.new(
name => RakuAST::Name.from-identifier('ACCEPTS'),
args => RakuAST::ArgList.new(
RakuAST::Var::Lexical.new('$_'),
),
),
),
postfix => RakuAST::Call::Method.new(
name => RakuAST::Name.from-identifier('Bool'),
),
),
),
),
),
);
$block.IMPL-CHECK($resolver, $context, False);
nqp::bindattr(self, RakuAST::Type::Subset, '$!where', $block);
}

my $type-object := self.stubbed-meta-object;
$type-object.HOW.set_name(
$type-object,
$!name.qualified-with(
RakuAST::Name.from-identifier-parts(
|nqp::split('::', $!current-package.HOW.name($!current-package))
)
).canonicalize(:colonpairs(0))
) if !nqp::eqaddr($!current-package, $resolver.get-global);

self.IMPL-INSTALL-SUBSET($resolver, $!name, $type-object);
}

method PRODUCE-STUBBED-META-OBJECT() {
Perl6::Metamodel::SubsetHOW.new_type(
:name($!name.canonicalize),
:refinee(Any),
:refinement(Any)
)
}

method PRODUCE-META-OBJECT() {
my $type := self.stubbed-meta-object;
if $!of {
$type.HOW.set_of($type, $!of.compile-time-value);
}
$type.HOW.set_where(
$type,
$!where.IMPL-CURRIED
?? $!where.IMPL-CURRIED.meta-object
!! $!where.compile-time-value
);
$type
}
}

0 comments on commit c17d5b2

Please sign in to comment.