Created
June 25, 2015 21:55
-
-
Save skids/7c86c24afd2ac49b0923 to your computer and use it in GitHub Desktop.
scratchfile where I'm implementing assuming
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
# 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