Skip to content

Instantly share code, notes, and snippets.

@skids
Created June 25, 2015 21:55
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save skids/7c86c24afd2ac49b0923 to your computer and use it in GitHub Desktop.
Save skids/7c86c24afd2ac49b0923 to your computer and use it in GitHub Desktop.
scratchfile where I'm implementing assuming
# POC second approximation to .assuming
#
# Try to break it (probably won't be too hard to at present.)
#
# This implements things like &foo.assuming(1,*,2,Nil,3) according
# to the special meanings specced for Nil and *.
#
# It also does something else which is not specced:
#
# It produces signatures representing both halves of the original
# signature, on which we can do some level of type-checking
# so that both .assuming and the produced closure can throw
# some typecheck errors earlier than the call to the original function.
#
# Since we are working with possibly incomplete halves, certain
# things cannot be typechecked, or are not worth the effort to
# typecheck. For example, where clauses and default
# values may depend on values which have not been provided yet,
# and may have side-effects. There are also some ways to make type
# captures and subsignatures really hairy. So these are all excised.
#
# Technically we might be able to do some analysis and run typechecks
# in more situations, but that is approaching the point of
# diminishing returns. This may be rewritten to more directly construct
# Signature objects rather than use EVAL, so maybe we could reach
# further after that.
#
# As a first phase, and to test further phases, any such typecheck
# failure will not be thrown, but rather mixed in to the returned
# closure. That should allow only "use fatal" code to see the
# failed early typechecks for now.
#
# This POC is currently just a sub, rather than monkey-patching it
# into a method on Block.
#
# This code currently requires https://github.com/rakudo/rakudo/pull/446
# which was just very recetly merged.
#
sub testassuming (Block $self, |primers) {
# sub strip-parm
# This is mostly a stripped-down version of Parameter.perl
# This removes where clauses, Turns "= { ... }" from defaults into just
# "?", removes type captures, removes subsignatures, and removes undeclared
# types (e.g. types set to or parameterized by captured types.)
my sub strip_parm (Parameter:D $parm) {
my $type = $parm.type.^name;
my $perl = $type;
my $rest = '';
my $truemu;
my $sigil = $parm.sigil;
my $elide_agg_cont= so ($sigil eqv '@'
or $sigil eqv '%'
or $type ~~ /^^ Callable >> /);
$perl = '' if $elide_agg_cont;
unless $type eq "Any" {
my $i = 0; # broken FIRST workaround
while ($type ~~ / (.*?) \[ (.*) \] $$/) {
my $slash0 = ~$0;
my $slash1 = ~$1;
# FIRST { # seems broken
unless ($i++) { # broken FIRST workaaround
$perl = ~$/;
if $elide_agg_cont {
$perl = ~$slash1;
$truemu = 'Mu ';
}
}
$type = ~$slash1;
try {
::($slash0);
CATCH { when X::NoSuchSymbol { $perl = ""; last } }
};
}
try { ::($type); CATCH { when X::NoSuchSymbol { $perl = ""; }}};
# Later on, undo 'Mu ' stripping because e.g. Positional !~~ Positional[Mu]
$truemu &&= '' if $perl ne 'Mu';
}
$truemu //= '';
# Introspection fail. There is no introspection to access these flags.
# Skipped for now. Also I have to wonder why this is special to the
# signature and not rather an annotation on types.
# if $!flags +& $SIG_ELEM_DEFINED_ONLY {
# $perl ~= ':D' if $perl ne '';
# } elsif $!flags +& $SIG_ELEM_UNDEFINED_ONLY {
# $perl ~= ':U' if $perl ne '';
# }
my $name = $parm.name;
if $name.substr(0,1) ne $sigil {
$name = $sigil ~ $parm.twigil ~ $name;
}
if $parm.slurpy {
# Slurpy scalars (and callables) are actually NYI
# according to spec AFAICT so until they are,
# nothing special to do here.
$name = '*' ~ $name;
} elsif $parm.named {
my @names := $parm.named_names;
$name = ':' ~ $_ ~ '(' ~ $name ~ ')'for @names;
$name ~= '!' unless $parm.optional;
} elsif $parm.optional or $parm.default {
$name ~= '?';
}
if $parm.rw {
$rest ~= ' is rw';
} elsif $parm.copy {
$rest ~= ' is copy';
}
if $parm.parcel and $name ~~ /^^ <[@$]>/ {
$rest ~= ' is parcel';
}
if $name or $rest {
$perl ~= ($perl ?? ' ' !! '') ~ $name;
$perl ~~ s/^^ \s* Mu \s+//;
}
$truemu ~ $perl ~ $rest;
}
my $trybind = True;
my @plist = (); # The list put in the returned closure's signature
my @clist = (); # The positional arguments used to call the original code
my @tlist = (); # Positional params to verify binding the primers against
my @alist = (); # Primers as positional arguments after processing
# Look for slurpies and captures
my $slurp_p;
my $slurp_n;
for $self.signature.params.grep(*.slurpy).kv -> $idx, $parm {
$slurp_p = $parm if $parm.sigil eq '@';
$slurp_p = :(*@RESERVED__ANON__SLURPY).params[0]
if $slurp_p.defined and not $slurp_p.name.defined;
$slurp_n = $parm if $parm.sigil eq '%';
$slurp_n = :(*%RESERVED__ANON__SLURPY).params[0]
if $slurp_n.defined and not $slurp_n.name.defined;
}
# Only use a capture if we do not have both slurpies (and one is present.)
unless $slurp_p.defined and $slurp_n.defined {
# Steal the earliest capture name. We may end up putting
# it at unfaithful offsets in the arglists, but we are
# mostly just using this internally. There is no clean way
# to do captures while tearing the signature.
my $cap;
$cap = $self.signature.params.first({ $_.capture and $_.name.defined })
// $self.signature.params.first({ $_.capture });
if $cap.defined and not $cap.name.defined {
$cap = :(|RESERVED__ANON__CAPTURE).params[0];
}
$slurp_p //= $cap;
$slurp_n //= $cap;
}
# Normal Positionals
my $sidx = 0;
for $self.signature.params.grep(*.positional).kv -> $idx, $parm {
unless $idx < primers.list.elems {
@plist.push($parm);
@clist.push($parm.name);
next;
}
given primers.list[$idx] {
when Whatever { @plist.push($parm);
@clist.push($parm.name); }
when Nil { @alist.push($parm.type);
@clist.push($parm.type.^name);
@tlist.push($parm); }
default { @alist.push($_);
@clist.push("primers.list[$idx]");
@tlist.push($parm); }
}
LEAVE {
$sidx = $idx + 1;
}
}
@tlist.push($slurp_p) if $slurp_p.defined;
@plist.push($slurp_p) if $slurp_p.defined;
my $idx = $sidx;
my $cidx = 0;
while ($idx < primers.list.elems) {
# We are priming with arity larger than the original
# Even with no slurpy we still go through the
# motions so we get good error handling.
given primers.list[$idx] {
when Whatever {
@clist.push($slurp_p.defined
?? $slurp_p.name ~ '[' ~ $cidx++ ~ ']' !! Nil);
}
when Nil {
my $t = "Any"; # "Mu"?
if $slurp_p.defined {
# Should it not be "Any" for captures? "Mu"?
unless $slurp_p.capture {
$t = $slurp_p.type.of.^name
}
}
@alist.push($t);
@clist.push($t);
}
default {
@alist.push($_);
@clist.push("primers.list[$idx]");
}
}
$idx++;
}
@clist.push("|" ~ $slurp_p.name ~ "[$cidx..*-1]" )
if $slurp_p.defined;
# Normal Nameds
my %phash = $self.signature.params.grep({$_.named and not $_.slurpy}).map({strip_parm($_) => $_});
my %thash = ();
my %ahash = primers.hash;
for %ahash.keys -> $name {
%thash = %phash.pairs.grep: { $name eq any(.value.named_names.list) };
%phash{%thash.keys}:delete;
}
$slurp_n = Nil if $slurp_n === $slurp_p; # Capture with no slurpies
if $slurp_n.defined {
%thash{strip_parm($slurp_n)} = $slurp_n;
$slurp_n = strip_parm($slurp_n)
}
$slurp_n //= ();
my $slurp_n_arg = $slurp_n;
$slurp_n_arg &&= '|' ~ $slurp_n_arg.substr(1);
say "will have signature {@plist.gist} / {%phash.keys.gist}";
say "will prime arguments {@alist.gist} / {%ahash.gist}";
say "will check primes vs {@tlist.gist} / {%thash.keys.gist}";
my $error = True;
try {
my constant $trycode = Q:to<EOCODE>;
my sub trybind (%s) { };
trybind(|@alist, |%%ahash);
EOCODE
printf($trycode, (@tlist.map(&strip_parm), %thash.keys).join(", "));
EVAL(sprintf($trycode,
(@tlist.map(&strip_parm), %thash.keys).join(", ")));
CATCH {
when X::TypeCheck::Binding {
$error = $_;
}
when X::AdHoc {
proceed unless $_.payload ~~ rx:s[Too many positionals];
$error = $_;
}
}
}
my constant $subcode = Q:to<EOCODE>;
my $s = sub (%s) {
$self(%s |%%ahash, %s);
}
EOCODE
printf($subcode,
(@plist.map(&strip_parm), %phash.keys, $slurp_n).join(", "),
(flat @clist, '').join(", "),
(%phash.values.map(":" ~ *.name), $slurp_n_arg).join(", ")
);
my $f = EVAL sprintf($subcode,
(@plist.map(&strip_parm), %phash.keys, $slurp_n).join(", "),
(flat @clist, '').join(", "),
(%phash.values.map(":" ~ *.name), $slurp_n_arg).join(", ")
);
$error ~~ Exception ?? $f but Failure.new($error) !! $f;
}
sub is-primed-sig (Block $b, Signature $s, Capture |cap) {
my $r = testassuming($b,|cap);
my $res = $r.signature.perl;
unless $res eq $s.perl and not $r.can('Failure') {
print "not ";
}
say 'OK Priming ' ~ $b.signature.perl ~ ' with ' ~ cap.perl ~ ' gave ' ~ $s.perl;
unless $res eq $s.perl {
say "Got $res instead";
}
if $r.can('Failure') {
$r.Failure.defined;
say "Binding test failed with: " ~ $r.Failure.gist;
}
}
sub priming-fails-bind (Block $b, $symbol, $expected, Capture |cap) {
my $r = testassuming($b,|cap);
my $expected_s = $expected;
$expected_s //= $expected.^name;
my $why = "";
if not $r.can('Failure') {
$why = "No Failure mixed in\n";
}
elsif $r.Failure.exception !~~ X::TypeCheck::Binding|X::AdHoc {
$why = 'Wrong X:: subtype ' ~ $r.Failure.exception.WHAT.perl;
}
elsif $r.Failure.exception ~~ X::TypeCheck::Binding and $r.Failure.exception.expected !=== $expected {
$why = "Wrong expected type { $r.Failure.exception.expected.perl } reported";
}
elsif $r.Failure.exception ~~ X::TypeCheck::Binding and $r.Failure.exception.symbol ne $symbol {
$why = "Wrong symbol { $r.Failure.exception.symbol } reported";
}
elsif $r.Failure.exception ~~ X::AdHoc and $r.Failure.exception.payload !~~ rx:s[$expected_s] {
$why = 'Wrong AdHoc Message: ' ~ $r.Failure.exception.payload;
}
my $not = $why ?? "not " !! "";
print "{$not}OK Priming { $b.signature.perl } with { cap.perl } mixed in a Failure ";
if not $r.can('Failure') {
say '';
}
elsif $r.Failure.exception ~~ X::AdHoc {
say "because $expected_s";
} else {
say "because $symbol !~~ $expected_s";
}
say $why;
}
sub is-primed-call (Block $b, \call, @expect, Capture |cap) {
my $r = testassuming($b,|cap);
my $res = $r.signature.perl;
my @res;
my @got;
if $r.can('Failure') or (@got = $r(|call)) !eqv @expect {
print "not ";
}
say "OK Primed function returns expected value { @expect.perl }";
unless @got eqv @expect {
say "Got { @got.perl } instead";
}
if $r.can('Failure') {
$r.Failure.defined;
say "Result was right but binding test failed with: " ~ $r.Failure.gist;
}
}
is-primed-sig(sub () { }, :(), );
is-primed-sig(sub ($a) { }, :(), 1);
is-primed-sig(sub ($a, $b) { }, :(Any $b), 1);
is-primed-sig(sub ($a?) { }, :(), 1);
is-primed-sig(sub ($a, $b?) { }, :(Any $b?), 1);
is-primed-sig(sub ($a?, $b?) { }, :(Any $b?), 1);
is-primed-sig(sub ($a = 2) { }, :(), 1);
is-primed-sig(sub ($a = 4, $b = 2) { }, :(Any $b?), 1);
is-primed-sig(sub ($a, $b) { }, :(Any $b), Nil);
is-primed-sig(sub ($a, $b) { }, :(Any $a), *, 2);
is-primed-sig(sub ($a, $b, $c) { }, :(Any $b), 1, *, 3);
is-primed-sig(sub ($a) { }, :(Any $a), *);
is-primed-sig(sub (:$a) { }, :(), :a);
is-primed-sig(sub (:$a, :$b) { }, :(Any :$a), :b);
is-primed-sig(sub (:$a, :$b) { }, :(Any :$b), :a);
is-primed-sig(sub (:$a?) { }, :(), :a);
is-primed-sig(sub (:$a?, :$b?) { }, :(Any :$a?), :b);
is-primed-sig(sub (:$a?, :$b?) { }, :(Any :$b?), :a);
is-primed-sig(sub (:$a!) { }, :(), :a);
is-primed-sig(sub (:$a!, :$b!) { }, :(Any :$a!), :b);
is-primed-sig(sub (:$a!, :$b!) { }, :(Any :$b!), :a);
is-primed-sig(sub (:$a = 2) { }, :(), :a);
is-primed-sig(sub (:$a = 2, :$b) { }, :(Any :$a?), :b);
is-primed-sig(sub (:$a = 2, :$b) { }, :(Any :$b), :a);
is-primed-sig(sub ($a, $b, :$c) { }, :(Any $b, Any :$c), 1);
is-primed-sig(sub (Str(Int) $a, $b, :$c) { }, :(Any $b, Any :$c), 1);
is-primed-sig(sub ($a, *@b) { }, :(*@b), 1);
is-primed-sig(sub ($a, *@b) { }, :(*@b), 1, 2);
is-primed-sig(sub ($a, *@b) { }, :(*@b), 1, 2, *, 3);
is-primed-sig(sub (*@b) { }, :(*@b), );
is-primed-sig(sub (*@b) { }, :(*@b), 1);
is-primed-sig(sub (*@b) { }, :(*@b), 1, *);
is-primed-sig(sub (*@b) { }, :(*@b), *, 2);
is-primed-sig(sub (*@b) { }, :(*@b), 1, *, 2);
is-primed-sig(sub ($a, *@b) { }, :(*@b), 1, 2, Nil, 3);
is-primed-sig(sub (*@b) { }, :(*@b), 1, Nil);
is-primed-sig(sub (*@b) { }, :(*@b), Nil, 2);
is-primed-sig(sub (*@b) { }, :(*@b), 1, Nil, 2);
priming-fails-bind(sub (Str $a) { }, '$a', Str, 1);
priming-fails-bind(sub (Int(Str) $a) { }, '$a', Str, 1);
priming-fails-bind(sub ($a) { }, "", "Too many positionals", 1, 2);
#?rakudo todo last part of RT 123498 is still unresolved.
#testassuming(sub { },:named)();
priming-fails-bind(sub { }, "", "Unexpected named parameter", :named);
sub abc123 ($a,$b,$c,$o,$t,$th) {
$a,$b,$c,$o,$t,$th;
}
proto testsubproto ($x, $y) {*}
multi testsubproto (Str $x, $y) { "Str + $y" }
multi testsubproto (Int $x, $y) { "Int + $y" }
multi testsub (Str $x, $y) { "Str + $y" }
multi testsub (Int $x, $y) { "Int + $y" }
sub tester(:$a, :$b, :$c) {
"a$a b$b c$c";
}
my &tester2 = testassuming(&tester, :b<b>);
sub capcap (|c ($a, $b?), |d ($c, $d?)) { "a$a b$b c$c d$d" };
sub capcapn (|c ($a, $b?, :$e = 'e'), |d ($c, $d?, :e($f) = 'f'), *%g) { "a$a b$b c$c d$d e$e f$f" };
sub anonslurp ($a, $b, *@, *%) { "a$a b$b" };
is-primed-call(&abc123, \(1,2,3), ['a','b','c',1,2,3], 'a','b','c');
is-primed-call(&sprintf, \(9..12), ["9abc"], "%x" x 4);
is-primed-call(&sprintf, \(10..12), ["9abc"], "%x" x 4, 9);
is-primed-call(&sprintf, \(9..12), ["9aabbc"], "%x" x 6, *, 10, *, 11);
is-primed-call(&testsubproto, \(43), ["Int + 43"], 42);
is-primed-call(&testsubproto, \(44), ["Str + 44"], "a Str");
is-primed-call(&testsub, \(43), ["Int + 43"], 42);
is-primed-call(&testsub, \(44), ["Str + 44"], "a Str");
is-primed-call(&tester, \(:a<w>, :c<y>), ['aw bx cy'], :b<x>);
is-primed-call(&tester2, \(:a<x>), ['ax bb cc'], :c<c>);
say tester2(:a<x>, :c<d>) eq 'ax bb cd' ?? "OK" !! "not OK";
is-primed-call(&capcap, \("b"), ['aa bb ca db'], 'a');
is-primed-call(&capcap, \("a"), ['aa bb ca db'], *, 'b');
is-primed-call(&capcapn, \("b"), ['aa bb ca db ee ff'], 'a');
is-primed-call(&capcapn, \("a"), ['aa bb ca db ee ff'], *, 'b');
is-primed-call(&capcapn, \("b"), ['aa bb ca db ee ff'], 'a', *);
is-primed-call(&capcapn, \("b"), ['aa bb ca db eE fE'], 'a', :e<E>);
is-primed-call(&capcapn, \("a"), ['aa bb ca db eE fE'], *, 'b', :e<E>);
is-primed-call(&capcapn, \("b"), ['aa bb ca db eE fE'], 'a', :e<E>);
is-primed-call(&capcapn, \("b"), ['aa bb ca db eE fE'], :e<E>, 'a');
is-primed-call(&capcapn, \("b"), ['aa bb ca db eE fE'], 'a', *, :e<E>);
is-primed-call(&capcapn, \("b"), ['aa bb ca db eE fE'], :e<E>, 'a', *);
is-primed-call(&capcapn, \("b"), ['aa bb ca db eE fE'], 'a', :e<E>, *);
is-primed-call(&anonslurp, \(1, 2, :a, 'c',:d), ['a1 b2']);
is-primed-call(&anonslurp, \(2, :a, 'c',:d), ['a1 b2'], 1);
is-primed-call(&anonslurp, \(:a, 'c',:d), ['a1 b2'], 1,2);
is-primed-call(&anonslurp, \('c',:d), ['a1 b2'], 1,2,:a);
is-primed-call(&anonslurp, \(:d), ['a1 b2'], 1, 2, :a, 'c');
is-primed-call(&anonslurp, \(), ['a1 b2'], 1, 2, :a, 'c', :d);
# How clever we get with type-captures and subsignatures is TBD. So the
# rest of these tests are more tenuous, they just test the intent
# of the currently prototyped functionality.
is-primed-sig(sub (::T $a, $b, :$c) { }, :(Any $b, Any :$c), 1);
is-primed-sig(sub (::T $a, T $b, T :$c) { }, :(Any $b, Any :$c), 1);
is-primed-sig(sub (::T $a, T @b, T :@c) { }, :(@b, :@c), 1);
is-primed-sig(sub (::T $a, T $b, T :$c) { }, :(Any :$c), 1, 1);
is-primed-sig(sub (::T $a, T @b, T :@c) { }, :(:@c), 1, [1]);
is-primed-sig(sub (::T $a, Array[T] $b, Array[Int] :$c) { }, :(Any $b, Array[Int] :$c), 1);
is-primed-sig(sub (::T $a, Array[T] $b, Array[Int] :$c) { }, :(Array[Int] :$c), 1, $(Array[Int].new));
is-primed-sig(sub (::T $a, Array[Array[T]] $b, Array[Array[Int]] :$c) { }, :(Any $b, Array[Array[Int]] :$c), 1);
is-primed-sig(sub (::T $a, Array[Positional[T]] $b, Array[Positional[Int]] :$c) { }, :(Any $b, Array[Positional[Int]] :$c), 1);
# How or whether this should fail is less clear to me. Currently LTA error.
# is-primed-sig(sub () { }, :(), *);
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment