Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Fix Parameter.perl and do Signature smart-matching.
  • Loading branch information
@clsn
clsn committed Jan 17, 2014
1 parent 82effd6 commit 5527210
Show file tree
Hide file tree
Showing 2 changed files with 136 additions and 59 deletions.
138 changes: 84 additions & 54 deletions src/core/Parameter.pm
View file
Expand Up @@ -131,64 +131,94 @@ my class Parameter { # declared in BOOTSTRAP
().list
}
}

method !flags() { $!flags }

method ACCEPTS(Parameter $other) {
return False unless $other.type ~~ $.type;
return False unless
$!flags +& $SIG_ELEM_DEFINED_ONLY <= $other!flags +& $SIG_ELEM_DEFINED_ONLY
and $!flags +& $SIG_ELEM_UNDEFINED_ONLY <=
$other!flags +& $SIG_ELEM_UNDEFINED_ONLY;
if $.sub_signature {
return False unless $other.sub_signature ~~ $.sub_signature;
}
if ($.named) {
return False unless $other.named;
return False unless Set($other.named_names) (<=) Set($.named_names);
}
return True;
}

# XXX TODO: A few more bits :-)
multi method perl(Parameter:D:) {
my $perl = '';
my $rest = '';
my $type = $!nominal_type.HOW.name($!nominal_type);
if $!flags +& $SIG_ELEM_ARRAY_SIGIL {
# XXX Need inner type
}
elsif $!flags +& $SIG_ELEM_HASH_SIGIL {
# XXX Need inner type
}
else {
$perl = $type;
if $!flags +& $SIG_ELEM_DEFINED_ONLY {
$perl ~= ':D';
} elsif $!flags +& $SIG_ELEM_UNDEFINED_ONLY {
$perl ~= ':U';
}
}
$perl = '' if $perl eq any(<Any Callable>);
$perl ~= ' ' if $perl;
if $!variable_name {
my $name = $!variable_name;
if $!flags +& $SIG_ELEM_IS_CAPTURE {
$perl ~= '|' ~ $name;
} elsif $!flags +& $SIG_ELEM_IS_PARCEL {
$perl ~= '\\' ~ $name;
} else {
my $default = self.default();
if self.slurpy {
$name = '*' ~ $name;
} elsif self.named {
my @names := self.named_names;
my $/ := $name ~~ / ^^ $<sigil>=<[$@%&]> $<desigil>=(@names) $$ /;
$name = ':' ~ $name if $/;
unless +@names == 1 and $_ and "\$$_" eq $name {
for @names {
next if $/ and $_ eq $<desigil>;
$name = ':' ~ $_ ~ '(' ~ $name ~ ')';
}
}
$name ~= '!' unless self.optional;
} elsif self.optional && !$default {
$name ~= '?';
}
$perl ~= $name;
if $!flags +& $SIG_ELEM_IS_RW {
$perl ~= ' is rw';
} elsif $!flags +& $SIG_ELEM_IS_COPY {
$perl ~= ' is copy';
}
$perl ~= ' = { ... }' if $default;
unless nqp::isnull($!sub_signature) {
$perl ~= ' ' ~ $!sub_signature.perl();
}
}
}
$perl
my $truemu='';

# XXX Need a CODE_SIGIL too?
if $!flags +& $SIG_ELEM_ARRAY_SIGIL or
$!flags +& $SIG_ELEM_HASH_SIGIL or
$type ~~ /^^ Callable >> / {
$type ~~ / .*? \[ <( .* )> \] $$/;
$perl = ~$/;
$truemu = 'Mu ' if $perl eq 'Mu'; # Positional !~~ Positional[Mu]
}
else {
$perl = $type;
}
if $!flags +& $SIG_ELEM_DEFINED_ONLY {
$perl ~= ':D';
} elsif $!flags +& $SIG_ELEM_UNDEFINED_ONLY {
$perl ~= ':U';
}
$perl ~= " ::$_" for @($.type_captures);
my $name = $!variable_name || '';
if $!flags +& $SIG_ELEM_IS_CAPTURE {
$name = '|' ~ $name;
} elsif $!flags +& $SIG_ELEM_IS_PARCEL {
$name = '\\' ~ $name unless $name ~~ /^^ <[@$]>/;
} elsif !$name {
if $!flags +& $SIG_ELEM_ARRAY_SIGIL {
$name = '@';
} elsif $!flags +& $SIG_ELEM_HASH_SIGIL {
$name = '%';
} elsif $type ~~ /^^ Callable >> / {
$name = '&';
} else {
$name = '$';
}
}
my $default = self.default();
if self.slurpy {
$name = '*' ~ $name;
} elsif self.named {
my @names := self.named_names;
$name = ':' ~ $_ ~ '(' ~ $name ~ ')'for @names;
$name ~= '!' unless self.optional;
} elsif self.optional && !$default {
$name ~= '?';
}
if $!flags +& $SIG_ELEM_IS_RW {
$rest ~= ' is rw';
} elsif $!flags +& $SIG_ELEM_IS_COPY {
$rest ~= ' is copy';
}
if $!flags +& $SIG_ELEM_IS_PARCEL and $name ~~ /^^ <[@$]>/ {
$rest ~= ' is parcel';
}
$rest ~= ' where { ... }' if !nqp::isnull($!post_constraints);
$rest ~= ' = { ... }' if $default;
unless nqp::isnull($!sub_signature) {
my $sig = $!sub_signature.perl();
$sig ~~ s/^^ ':'//;
$rest ~= ' ' ~ $sig;
}
if $name ne '$' or $rest {
$perl ~= ($perl ?? ' ' !! '') ~ $name;
$perl ~~ s/^^ \s* Mu \s+//;
}
$truemu ~ $perl ~ $rest;
}

method sub_signature(Parameter:D:) {
Expand Down
57 changes: 52 additions & 5 deletions src/core/Signature.pm
View file
Expand Up @@ -19,12 +19,57 @@ my class Signature { # declared in BOOTSTRAP
}

multi method ACCEPTS(Signature:D: Signature:D $topic) {
return False unless $topic.params == self.params;
my $sclass = self.params.classify({.named});
my $tclass = $topic.params.classify({.named});
my @spos := $sclass<False> // ();
my @tpos := $tclass<False> // ();

for $topic.params Z self.params -> $t, $s {
return False unless $t.type ~~ $s.type;
}
while @spos {
my $s;
my $t;
last unless $t=@tpos.shift;
$s=@spos.shift;
if $s.slurpy or $s.capture {
@spos=();
@tpos=();
last;
}
if $t.slurpy or $t.capture {
return False unless @spos.grep({.slurpy or .capture});
@spos=();
@tpos=();
last;
}
if not $s.optional {
return False if $t.optional
}
return False unless $t ~~ $s;
}
return False if @tpos;
if @spos {
return False unless @spos[0].optional or @spos[0].slurpy or @spos[0].capture;
}

for ($sclass<True> // ()).grep({!.optional and !.slurpy}) -> $this {
my $other;
return False unless $other=($tclass<True> // ()).grep(
{!.optional and $_ ~~ $this });
return False unless +$other == 1;
}

my $here=$sclass<True>.SetHash;
my $hasslurpy=($sclass<True> // ()).grep({.slurpy}).Bool;
for @($tclass<True> // ()) -> $other {
my $this;

return $hasslurpy if $other.slurpy;
if $this=$here.keys.grep( -> $t { $other ~~ $t }) {
$here{$this[0]} :delete;
}
else {
return False unless $hasslurpy;
}
}
return True;
}

Expand Down Expand Up @@ -78,7 +123,9 @@ my class Signature { # declared in BOOTSTRAP
$sep = ($i == 0 && $param.invocant) ?? ': ' !! ', ';
$i = $i + 1;
}

if $!returns !=:= Mu {
$perl ~= ' --> ' ~ $!returns.perl
}
# Closer.
$perl ~ ')'
}
Expand Down

0 comments on commit 5527210

Please sign in to comment.