Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

4596 lines (4081 sloc) 154.731 kb
# vim: ft=perl6 fdm=marker
my module CORE;
use MONKEY_TYPING;
# The contract for 'is pure' is that, when provided a set of positional and
# named arguments all of which are of immutable types, an immutable object
# is returned which depends only on the arguments, not on any free variables.
# In particular, any function which necessarily takes or returns a List
# is excluded.
# However, slurpy arguments are ok. If an object is claimed to be immutable
# but implements variable methods for Bool,Str,Int,etc, no rules apply.
#
# There are three senses of 'immutability' currently used in Niecza. For an
# expression, being immutable means that the same Variable will always be
# returned (that is, =:=) and there are no side effects, so that expression
# can effectively be constant-folded. const_value will return either a
# Value downvalue or Nil depending on (an approximation to) such immutability.
#
# For values, immutability is measured by the 'immutable' method, and is true
# if none of the object's state, as seen by perl, eqv, or other such accesors,
# can be changed. Variables are immutable if they are read-only and their
# value is immutable. Note that an immutable expression can return a mutable
# variable!
#
# Known suboptimalities of this system: it doesn't make a whole lot of sense
# to be forbidding (3 => 5) but, but allowing (3 => $x) but. Also, we could
# usefully fold some cases like "foo" => &bar, even though &bar is not
# immutable.
# Predeclarations of types {{{
my class Mu { ... }
my grammar Cursor { ... }
my class Regex { ... }
my class Num { ... }
my class Str { ... }
my class Code { ... }
my class Match { ... }
my class List { ... }
my class Array { ... }
my class FatRat { ... }
my class Junction { ... }
my class Enum { ... }
my class Range { ... }
my class Whatever { ... }
my class IO { ... }
our class IO::Path { ... }
my class ObjAt { ... }
my class Proxy { ... }
my class Set { ... }
my class SetHash { ... }
my class Bag { ... }
my class BagHash { ... }
my class Pair { ... }
grammar Niecza::NumSyntax { ... }
# }}}
# Important inlinable definitions {{{
proto infix:<+>($?,$?) is pure is Niecza::builtin('plus',2,2) {*}
multi infix:<+>($l,$r) { $l + $r }
proto infix:<->($?,$?) is pure is Niecza::builtin('minus',2,2) {*}
multi infix:<->($l,$r) { $l - $r }
proto infix:<*> is pure is Niecza::builtin('mul',2,2) is Niecza::absprec<u=> ($?,$?) {*}
multi infix:<*>($l,$r) { $l * $r }
proto infix:</> is pure is Niecza::builtin('divide',2,2) is equiv<*> ($?,$?) {*}
multi infix:</>($l,$r) { $l / $r }
proto infix:<%> is pure is Niecza::builtin('mod',2,2) is equiv<*> ($?,$?) {*}
multi infix:<%>($l,$r) { $l % $r }
proto infix:<**> is pure is Niecza::builtin('pow',2,2) is Niecza::absprec<w= right> ($?,$?) {*}
multi infix:<**>($l,$r) { $l ** $r }
# sub infix:<gcd>($l,$r) is Niecza::builtin('gcd',2,2) { $l gcd $r }
sub infix:<gcd>($l,$r) is pure { Q:CgOp { (gcd {$l.Int} {$r.Int}) } }
sub infix:<lcm>($l,$r) is pure {
my $l-int = $l.Int.abs;
my $r-int = $r.Int.abs;
$l-int div ($l-int gcd $r-int) * $r-int;
}
sub next ($x?) { _lexotic(1, $x, ()) }
sub last ($x?) { _lexotic(2, $x, ()) }
sub redo ($x?) { _lexotic(3, $x, ()) }
sub return(\|@pcl) is return-pass { Q:CgOp {
(control 4 (null frame) (int -1) (null str) {@pcl.unwrap-single})
} }
sub return-rw(\|@pcl) is return-pass { Q:CgOp {
(control 4 (null frame) (int -1) (null str) {@pcl.unwrap-single})
} }
sub succeed(\|@pcl) {
Q:CgOp { (control 6 (null frame) (int -1) (null str) {@pcl.unwrap-single}) }
}
sub proceed() { proceed }
sub term:<proceed>() {
Q:CgOp { (control 7 (null frame) (int -1) (null str) {()}) }
}
sub take(\|@pcl) { Q:CgOp { (take {@pcl.unwrap-single}) } }
sub take-rw(\|@pcl) { Q:CgOp { (take {@pcl.unwrap-single}) } }
sub infix:<&> is pure is Niecza::absprec<q= list> is iffy
(\|$p) { Junction.from-parcel(0, $p) }
sub infix:<|> is pure is Niecza::absprec<p= list> is iffy
(\|$p) { Junction.from-parcel(3, $p) }
sub infix:<^> is pure is equiv<|> (\|$p) { Junction.from-parcel(2, $p) }
sub all (*@p) is pure { all @p }
sub none (*@p) is pure { none @p }
sub one (*@p) is pure { one @p }
sub any (*@p) is pure { any @p }
proto infix:<< == >>($?,$?) is pure is Niecza::builtin('numeq',2,2)
is Niecza::absprec<m= chain> is diffy is iffy {*}
proto infix:<< != >>($?,$?) is pure is Niecza::builtin('numne',2,2)
is equiv<==> {*}
proto infix:<< < >>($?,$?) is pure is Niecza::builtin('numlt',2,2)
is equiv<==> {*}
proto infix:<< > >>($?,$?) is pure is Niecza::builtin('numgt',2,2)
is equiv<==> {*}
proto infix:<< <= >>($?,$?) is pure is Niecza::builtin('numle',2,2)
is equiv<==> {*}
proto infix:<< >= >>($?,$?) is pure is Niecza::builtin('numge',2,2)
is equiv<==> {*}
multi infix:<< == >>($l,$r) { $l == $r }
multi infix:<< != >>(\l,\r) { l != r } # Needs special handling of junctions
multi infix:<< < >>($l,$r) { $l < $r }
multi infix:<< > >>($l,$r) { $l > $r }
multi infix:<< <= >>($l,$r) { $l <= $r }
multi infix:<< >= >>($l,$r) { $l >= $r }
proto infix:<ge>($?,$?) is Niecza::builtin('strge',2,2) is equiv<==> is pure {*}
proto infix:<gt>($?,$?) is Niecza::builtin('strgt',2,2) is equiv<==> is pure {*}
proto infix:<le>($?,$?) is Niecza::builtin('strle',2,2) is equiv<==> is pure {*}
proto infix:<lt>($?,$?) is Niecza::builtin('strlt',2,2) is equiv<==> is pure {*}
proto infix:<eq>($?,$?) is Niecza::builtin('streq',2,2) is equiv<==> is pure {*}
proto infix:<ne>($?,$?) is Niecza::builtin('strne',2,2) is equiv<==> is pure {*}
multi infix:<ge>($s1, $s2) { $s1 ge $s2 }
multi infix:<gt>($s1, $s2) { $s1 gt $s2 }
multi infix:<le>($s1, $s2) { $s1 le $s2 }
multi infix:<lt>($s1, $s2) { $s1 lt $s2 }
multi infix:<eq>($s1, $s2) { $s1 eq $s2 }
multi infix:<ne>(\s1, \s2) { s1 ne s2 } # Needs special handling of junctions
sub infix:<,> is Niecza::builtin('comma',0) is pure is Niecza::absprec<g= list> (\|$t) { Q:CgOp { (newrwlistvar (@ {$t})) }; }
proto infix:<=>($?,$?) is Niecza::absprec<i= right> is Niecza::builtin('assign',2,2) {*}
multi infix:<=>(\a, \b) { a = b }
sub chars($str) is pure is Niecza::builtin('chars',1,1) { chars($str) }
sub codes($str) is pure is Niecza::builtin('codes',1,1) { codes($str) }
sub defined(\x) is pure is Niecza::builtin('defined',1,1) { defined(x) }
sub prefix:<~>(\v) is pure is Niecza::builtin('asstr', 1, 1) { ~v }
sub prefix:<?>(\v) is pure is Niecza::builtin('asbool', 1, 1) { ?v }
sub prefix:<->(\v) is pure is Niecza::builtin('negate', 1, 1) { -v }
sub prefix:<+>(\v) is pure is Niecza::builtin('num', 1, 1) { +v }
sub prefix:<!>(\v) is pure is Niecza::builtin('not', 1, 1) { !v }
sub not(\v) is pure is Niecza::builtin('not', 1, 1) { not(v) }
sub so(\v) is pure is Niecza::builtin('asbool', 1, 1) { so v }
proto infix:<+&> is pure is Niecza::builtin('numand',2,2) is equiv<*> ($?,$?) {*}
proto infix:<+|>($?,$?) is pure is Niecza::builtin('numor',2,2) {*}
proto infix:<+^>($?,$?) is pure is Niecza::builtin('numxor',2,2) {*}
proto infix:<< +< >>($?,$?) is equiv<*> is pure
is Niecza::builtin('numlshift',2,2) {*}
proto infix:<< +> >>($?,$?) is equiv<*> is pure
is Niecza::builtin('numrshift',2,2) {*}
proto prefix:<< +^ >>(|) is Niecza::builtin('numcompl',1,1) is pure {*}
multi infix:<+&> ($x, $y) { $x +& $y }
multi infix:<+|>($x, $y) { $x +| $y }
multi infix:<+^>($x, $y) { $x +^ $y }
multi infix:<< +< >>($x, $y) { $x +< $y }
multi infix:<< +> >>($x, $y) { $x +> $y }
multi prefix:<< +^ >>($x) { +^$x }
sub infix:<< => >>($k, Mu $v) is equiv<=> is pure
is Niecza::builtin('pair', 2, 2) { $k => $v }
sub postcircumfix:<[ ]>(\container, |stuff) {
container.postcircumfix:<[ ]>(|stuff)
}
sub postcircumfix:<{ }>(\container, |stuff) {
container.postcircumfix:<{ }>(|stuff)
}
sub push(@array, *@stuff) is Niecza::builtin('push', 1) { @array.push(@stuff) }
sub unshift(@array, *@stuff) is Niecza::builtin('unshift', 1) { @array.unshift(@stuff) }
sub pop(@array) is Niecza::builtin('pop', 1, 1) { @array.pop }
sub shift(@array) is Niecza::builtin('shift', 1, 1) { @array.shift }
multi sub splice(@array is rw) { @array.splice() }
multi sub splice(@array is rw, *@values) { @array.splice(@values) }
multi sub splice(@array is rw, $offset, *@values) { @array.splice($offset,Inf,@values); }
multi sub splice(@array is rw, $offset, $size, *@values) { @array.splice($offset, $size, @values); }
sub grep(Mu $filter, *@items) is Niecza::builtin('grep',1) { grep($filter, @items) }
sub map($callback, *@items) is Niecza::builtin('map',1) { map($callback, @items) }
sub _array_constructor(\parcel) is Niecza::builtin('array_constructor', 1,
1) { _array_constructor(parcel) }
sub make($x) is Niecza::builtin('make', 1, 1) { make $x }
# these are defined in terms of other operators so they go at the end
sub prefix:<--> is Niecza::absprec<x= unary non> is Niecza::builtin('predec',1,1) ($v is rw) { $v = $v.pred; $v }
sub prefix:<++> is equiv<--> is Niecza::builtin('preinc',1,1) ($v is rw) { $v = $v.succ; $v }
sub postfix:<--> is Niecza::absprec<x= unary non> is Niecza::builtin('postdec',1,1) ($v is rw) { my $old = $v; $v = $v.pred; $old }
sub postfix:<++> is equiv<--> is Niecza::builtin('postinc',1,1) ($v is rw) { my $old = $v; $v = $v.succ; $old }
sub substr(\str, $start, $len?, $repl?) is Niecza::builtin('substr_ro3', 3, 3) is pure {
$start := $start(chars str) if $start.^does(Code);
$len := $len.^does(Code) ?? ($len(chars str) - $start) !!
$len // (chars(str) - $start);
defined($repl) ??
substr-rw(str, $start, $len) = $repl !!
substr(str, $start, $len)
}
# Right now, this compltely duplicates the code of substr. substr needs to be fixed so
# that it isn't an lvalue, and the code below should remain substr-rw.
sub substr-rw(\str, $start, $len?, $repl?) is Niecza::builtin('substr3', 3, 3) is pure {
$start := $start(chars str) if $start.^does(Code);
$len := $len.^does(Code) ?? ($len(chars str) - $start) !!
$len // (chars(str) - $start);
defined($repl) ??
substr-rw(str, $start, $len) = $repl !!
substr-rw(str, $start, $len)
}
# not actually inlined but needed for constant i
sub sqrt($x) is pure { Q:CgOp { (sqrt {$x}) } }
sub Niecza::toggle_mono_trace() { Q:CgOp { (prog (raise (s "SIGUSR2")) {0}) } }
sub infix:<X>(\|$pcl) is Niecza::absprec<f= list> {
Q:CgOp { (cross (b 0) (unbox fvarlist (@ {$pcl}))) }
}
sub infix:<Z>(\|$pcl) is equiv<X> {
Q:CgOp { (zip (b 0) (unbox fvarlist (@ {$pcl}))) }
}
sub zipop(\|$pcl) {
Q:CgOp { (zip (b 1) (unbox fvarlist (@ {$pcl}))) }
}
sub crossop(\|$pcl) {
Q:CgOp { (cross (b 1) (unbox fvarlist (@ {$pcl}))) }
}
# }}}
# Fundamental types {{{
my constant True = 1.Bool;
my constant False = 0.Bool;
my class Mu {
method head() { @(self).head }
method flattens(\:) {
Q:CgOp { (box Bool (var_islist {self})) }
}
method typename() { # should be ^name
Q:CgOp { (box Str (obj_typename (@ {self}))) }
}
method gist() { defined(self) ?? self.perl !! '(' ~ self.typename ~ ')' }
method say() { self.gist.say }
method print() { $*OUT.print(self) }
method Stringy() { self.Str }
method Str() {
if defined(self) {
my $tn := Q:CgOp { (box Str (obj_typename (@ {self}))) };
$tn ~ "()<instance>"
} else {
warn "Use of uninitialized value in string context";
""
}
}
method succ() { defined(self) ?? die("cannot increment a value of type {self.typename()}") !! 1 }
method pred() { defined(self) ?? die("cannot decrement a value of type {self.typename()}") !! -1 }
method notdef() { !defined(self) }
method ACCEPTS(\x) { defined(self) ?? self === x !! x.^does(self) }
method perl() { defined(self) ?? "{self.typename}.new(...)" !! self.typename }
method so() { ?self }
method not() { !self }
multi method bless($, *%_) {
warn "Passing an object candidate to Mu.bless is deprecated";
Q:CgOp { (default_new (@ {self}) (unbox varhash (@ {%_}))) }
}
multi method bless(*%_) { Q:CgOp { (default_new (@ {self}) (unbox varhash (@ {%_}))) } }
method CREATE() { Q:CgOp { (obj_newblank (obj_llhow (@ {self}))) } }
multi method new(*%_) { Q:CgOp { (default_new (@ {self}) (unbox varhash (@ {%_}))) } }
method clone(*%_) { Q:CgOp { (repr_clone (@ {self}) (unbox varhash (@ {%_}))) } }
method dispatch:<::>(|) { Q:CgOp { (dispatch_fromtype) } }
method immutable() { !defined(self) }
method take() { take self }
multi method WHICH() { ObjAt.new(str => '', ref => self) }
}
my class Any is Mu {
method isa(\other) { self.^isa(other) }
method does(\other) { self.^does(other) }
method can($method) { self.^can($method) }
method flat() { @(self) }
method Numeric() {
die "Cannot use value like $.typename as a number" if defined(self);
warn "Use of uninitialized value in numeric context";
0;
}
# This needs a way of taking a user-defined comparison
# specifier, but AFAIK nothing has been spec'd yet.
# CHEAT: Almost certainly should be hashed on something
# other than the stringification of the objects.
method uniq() {
my %seen;
gather for @(self) {
unless %seen{$_} {
take $_;
%seen{$_} = 1;
}
}
}
method kv() {
my $i = 0;
gather for @(self) -> \value {
my $key = $i++;
take $key;
take value;
}
}
method keys() {
my $i = 0;
gather for @(self) -> $value { #OK not used
my $key = $i++;
take $key;
}
}
method values() {
gather for @(self) -> \value {
take value;
}
}
method pairs() {
self.kv.map(-> $key, \value { $key => value; });
}
# NOTE: These functions are called by the default postcircumfixes, *after*
# processing slicing and adverbs. So you should probably override these
# instead. However, for speed, Array, Hash et al override the
# postcircumfixes instead, and so you can't change their behavior using
# delete_key and company in subclasses.
method delete_key($) {
die "Cannot use hash access on an object of type {self.WHAT.perl}"
}
method exists_key($) {
die "Cannot use hash access on an object of type {self.WHAT.perl}"
}
method at_key($) {
die "Cannot use hash access on an object of type {self.WHAT.perl}"
}
method bind_key($, $) {
die "Cannot use hash access on an object of type {self.WHAT.perl}"
}
method at_pos($key) { self.list.at_pos($key) }
method bind_pos($, $) {
die "Cannot use hash access on an object of type {self.WHAT.perl}"
}
method grep(Mu $sm) { grep $sm, @(self) }
method map($func) { map $func, @(self) }
method for (&cb) {
Q:CgOp {
(rnull (letn it (unbox vvarlist (@ {self.iterator}))
cb (@ {&cb})
(whileloop 0 0 (iter_hasflat (l it))
(sink (subcall (l cb) (vvarlist_shift (l it)))))))
};
}
method elems() { self.flat.elems }
method end() { self.defined ?? self.elems - 1 !! -1 }
method iterator() { self.flat.iterator }
method join($sep = "") { self.flat.join($sep) }
method chrs() { chrs(@(self)) }
method any() { any @(self) }
method none() { none @(self) }
method all() { all @(self) }
method one() { one @(self) }
method sort($cmp = &infix:<cmp>) { @(self).sort($cmp) }
method first(Mu $filter) { for @(self) { return $_ if $_ ~~ $filter } }
method !butWHENCE($cr) {
Q:CgOp { (newvsubvar (class_ref mo Any) (@ {$cr}) (@ {self})) }
}
method hash() { anon %hash = @(self) }
multi method roll($num = 1) {
return { self[floor(self.elems.rand)] } xx * if $num ~~ Whatever;
return self[floor(self.elems.rand)] if $num == 1;
return map { self[floor(self.elems.rand)] }, ^$num;
}
multi method pick($num is copy = 1) {
my @l = @(self);
if ($num ~~ Whatever) {
$num = @l.elems;
} elsif ($num == 1) {
return @l[floor(@l.elems.rand)];
}
my $number-elements = @l.elems;
gather {
while ($num > 0 and $number-elements > 0) {
my $idx = floor($number-elements.rand());
my $old = @l[$idx];
@l[$idx] = @l[--$number-elements];
take $old;
--$num;
}
}
}
method rotate($n = 1) { @(self).rotate($n) }
method min($cmp = &infix:<cmp>) { @(self).min($cmp) }
method max($cmp = &infix:<cmp>) { @(self).max($cmp) }
method minmax($cmp = &infix:<cmp>) { @(self).minmax($cmp) }
method reduce($expression) {
my $result;
my $first = 1;
for @(self) -> $cur {
if $first {
$result = $cur;
$first = 0;
next;
}
$result = &$expression($result, $cur);
}
$result;
}
method classify($test) { {}.classify( $test, @(self) ) }
}
sub Niecza::autopun($pun, $name) {
-> | { Q:CgOp { (rnull (pun_helper {$pun} {$name} (callframe))) }; nextsame }
}
sub IMMUTABLE(\x) { Q:CgOp { (ternary (var_is_rw {x}) {False} {x.immutable}) } }
my class Empty {
method new() { Empty }
method iterator() { ().iterator }
method gist() { '' }
method Str() { '' }
method flat() { self.iterator.flat }
method list() { self.iterator.list }
method at_pos($key) { @(self).[$key] }
method Capture () { ().Capture }
method elems () { 0 }
method Numeric() { 0 }
method Bool () { ?0 }
}
my class Nil {
method new() { Nil }
method iterator() { ().iterator }
method gist() { 'Nil' }
# XXX the default won't work because of Nil's exotic binding behavior
multi method WHICH() { ObjAt.new(str => 'Nil', ref => Any) }
method Str() { warn "Use of Nil as a string"; '' }
method flat() { self.iterator.flat }
method list() { self.iterator.list }
method at_pos($key) { @(self).[$key] }
method Capture () { ().Capture }
method elems () { 0 }
method Numeric() { warn "Use of Nil as a number"; 0 }
method Bool () { ?0 }
method FALLBACK (|) { Nil }
}
my class Cool {
method FatRat () { Niecza::NumSyntax.str2num(~self, :fatrat) }
method Rat($eps = 1e-6) { Q:CgOp { (rat_approx {self} {$eps}) } }
method Int() { Q:CgOp { (coerce_to_int {self}) } }
method Num() { Q:CgOp { (coerce_to_num {self}) } }
method IO() { self.Str.IO }
method abs() { abs self }
method floor() { floor self }
method ceiling() { ceiling self }
method round($scale = 1) { round self, $scale }
method truncate() { truncate self }
method sqrt() { sqrt self }
method sign() { sign self }
method conj() { self }
multi method exp() { Q:CgOp { (exp {self}) } }
multi method exp($base) { $base ** self }
method ln() { Q:CgOp { (ln {self}) } }
multi method log() { self.ln }
multi method log($base) { self.ln / $base.ln }
method log10() { self.ln / 10.ln }
method sin() { Q:CgOp { (sin {self}) } }
method asin() { Q:CgOp { (asin {self}) } }
method cos() { Q:CgOp { (cos {self}) } }
method acos() { Q:CgOp { (acos {self}) } }
method tan() { Q:CgOp { (tan {self}) } }
method atan() { Q:CgOp { (atan {self}) } }
method sec() { Q:CgOp { (sec {self}) } }
method asec() { Q:CgOp { (asec {self}) } }
method cosec() { Q:CgOp { (cosec {self}) } }
method acosec() { Q:CgOp { (acosec {self}) } }
method cotan() { Q:CgOp { (cotan {self}) } }
method acotan() { Q:CgOp { (acotan {self}) } }
method sinh() { Q:CgOp { (sinh {self}) } }
method asinh() { Q:CgOp { (asinh {self}) } }
method cosh() { Q:CgOp { (cosh {self}) } }
method acosh() { Q:CgOp { (acosh {self}) } }
method tanh() { Q:CgOp { (tanh {self}) } }
method atanh() { Q:CgOp { (atanh {self}) } }
method sech() { Q:CgOp { (sech {self}) } }
method asech() { Q:CgOp { (asech {self}) } }
method cosech() { Q:CgOp { (cosech {self}) } }
method acosech() { Q:CgOp { (acosech {self}) } }
method cotanh() { Q:CgOp { (cotanh {self}) } }
method acotanh() { Q:CgOp { (acotanh {self}) } }
method atan2($x = 1) { Q:CgOp { (atan2 {self} {$x}) } }
method polar() { self.abs, atan2(0, self); }
method unpolar($angle) { unpolar(self, $angle); }
method cis() { cis(self); }
method rand() { self * rand; }
method roots($n) { roots(self, $n); }
method gamma() { Q:CgOp { (gamma {self}) } }
method lgamma() { Q:CgOp { (lgamma {self}) } }
method expm1() { Q:CgOp { (expm1 {self}) } }
method log1p() { Q:CgOp { (log1p {self}) } }
method erf() { Q:CgOp { (erf {self}) } }
method split($matcher, $limit?, :$all?) {
my $matchrx = (($matcher ~~ Regex) ?? $matcher !! /$matcher/);
my $str = ~self;
my $C = Cursor.cursor_start($str);
my @out;
my $i = 0;
my $last = 0;
my $limctr = $limit ~~ Whatever ?? Inf !! $limit // Inf;
my $M;
while ($i <= chars $str) && ($limctr > 1) {
$M = head($matchrx($C.cursor($i++)));
if $M {
push @out, substr($str, $last, ($M.from - $last));
push @out, $M if $all;
$i = $i max ($last = $M.to);
$limctr = ($limctr - 1);
}
}
push @out, substr($str, $last, (chars($str) - $last));
@out;
}
sub _match_nth($ix, @nth) {
shift @nth while @nth && @nth[0] < $ix;
@nth && @nth[0] == $ix;
}
method match($pat, :st(:rd(:nd(:th(:$nth)))), :c(:$continue), :p(:$pos)) {
my $ix = $continue // $pos // 0;
my $str = ~self;
if $ix && ($ix === ?1) {
$ix = CALLER::CALLER::<$/> ?? CALLER::CALLER::<$/>.to !! 0;
}
my $max = chars $str;
my $incr = Cursor.cursor_start($str);
my $indx = 0;
$nth := [ @$nth ] if defined($nth);
while $ix <= $max {
my $mat = head($pat.($incr.cursor($ix++)));
if $mat && (!defined($nth) || _match_nth(++$indx, $nth)) {
Q:CgOp { (rnull (set_status (s $/) {$mat})) };
return unitem($mat);
}
$ix = $ix max $mat.to if defined $mat;
$ix = $max + 1 if defined($pos);
}
Q:CgOp { (rnull (set_status (s $/) {Nil})) };
Nil;
}
method subst(\: $matcher_, $replacement, :g(:$global), :$x,
:c(:$continue), :th(:st(:nd(:rd(:$nth)))), :p(:$pos), :$inplace) {
die ":pos may not be used with :continue" if
defined($pos) && defined($continue);
die ":x may not be used with :global" if defined($x) && $global;
my $old := CALLER::<$/>;
LEAVE CALLER::<$/> := $old unless $inplace;
my $str = ~self;
my $C = Cursor.cursor_start($str);
my $matcher = $matcher_ ~~ Regex ?? $matcher_ !! /$matcher_/;
my $i = $pos // $continue // 0;
if ($i === ?1) {
$i = $old ?? $old.to !! 0;
}
$nth := [ @$nth ] if defined $nth;
my $to = 0;
my $changes = 0;
my $limctr = ($global || defined($x) && $x ~~ Whatever) ?? Inf
!! defined($x) ?? $x.niecza_quantifier_max !! 1;
my @out;
my $index = 0;
while $i < chars($str) && $limctr {
my $M = head($matcher($C.cursor($i++)));
if $M && $M.chars {
Q:CgOp { (rnull (set_status (s '$/') {$M})) };
$i = $M.to max $i;
unless defined($nth) && !_match_nth(++$index, $nth) {
$changes++;
push @out, substr($str,$to,$M.from-$to);
push @out, ($replacement ~~ Str ?? $replacement
!! $replacement.count == 1 ?? $replacement($M) !! $replacement());
$to = $i = $M.to;
$limctr = $limctr - 1;
}
} else {
last if defined($pos);
}
}
my $res = join "", @out, substr($str,$to,chars($str)-$to);
if defined($x) && $changes !~~ $x {
$res = $str;
}
if $inplace {
self = $res;
?$changes;
} else {
$res;
}
}
method wordcase() { self.lc.subst(:g, /\w+/, { tclc $/ }) }
method index($substring, $pos?) {
my $str = ~self;
my $fromc = defined($pos) ?? ($pos min chars $str) !! 0;
my $len = chars $substring;
my $maxi = chars($str) - $len;
while $fromc <= $maxi {
if substr($str,$fromc,$len) eq $substring {
return $fromc;
}
$fromc++;
}
Num; # XXX StrPos
}
method rindex($substring, $from?) {
my $str = ~self;
my $len = chars $substring;
my $fromc = (($from // 1_000_000_000) min (chars($str) - $len));
while $fromc >= 0 {
if substr($str,$fromc,$len) eq $substring {
return $fromc;
}
$fromc = $fromc - 1;
}
Num; # XXX StrPos
}
method comb($matcher = /./, $limit?, :$match) {
my $str = ~self;
my $C = Cursor.cursor_start($str);
my $i = 0;
my $limctr = $limit ~~ Whatever ?? Inf !! $limit // Inf;
my @out;
while ($i < chars $str) && $limctr > 0 {
my $M = head($matcher($C.cursor($i++)));
if $M {
$i max= $M.to;
push @out, ($match ?? $M !! (~$M));
$limctr = $limctr - 1;
}
}
@out
}
method lines($limit = *) {
self.comb(/ ^^ \N* /, $limit);
}
method words($limit = 1_000_000_000) {
self.comb(/ \S+ /, $limit);
}
method words-val() { map &val, self.words }
method chars() { chars(self) }
method codes() { codes(self) }
method chomp() {
my $s = ~self;
my $l = chars($s);
--$l if $l && substr($s, $l-1, 1) eq "\x0A";
--$l if $l && substr($s, $l-1, 1) eq "\x0D";
substr($s,0,$l);
}
method p5chomp($self is rw:) {
my $s = ~$self;
my $l = chars($s);
my $ol = $l;
--$l if $l && substr($s, $l-1, 1) eq "\x0A";
--$l if $l && substr($s, $l-1, 1) eq "\x0D";
$self = substr($s,0,$l);
$ol - $l;
}
method chop() {
my $s = ~self;
substr($s, 0, chars($s) - 1)
}
method p5chop($self is rw:) {
my $str = ~$self;
return '' if $str eq '';
my $end = substr($str, chars($str)-1, 1);
$self = substr($str, 0, chars($str)-1);
$end;
}
method substr(\: $start, $len?, $repl?) {
$start := $start(chars self) if $start.^does(Code);
$len := $len.^does(Code) ?? ($len(chars self) - $start) !!
$len // (chars(self) - $start);
defined($repl) ??
substr(self, $start, $len) = $repl !!
substr(self, $start, $len)
}
method lc() { Q:CgOp { (box Str (str_tolower (obj_getstr {self}))) }}
method uc() { Q:CgOp { (box Str (str_toupper (obj_getstr {self}))) }}
method tc() {
self ~~ /^(.)(.*)$/ ?? Q:CgOp { (box Str (ucd_titlecase { $0.ord })) } ~ $1 !! "";
}
method tclc() {
self ~~ /^(.)(.*)$/ ?? Q:CgOp { (box Str (ucd_titlecase { $0.ord })) } ~ $1.lc !! "";
}
method flip() { Q:CgOp { (box Str (str_flip (obj_getstr {self}))) }}
method lcfirst() { lcfirst(self) }
method ord() { ord(self) }
method chr() { chr(self) }
method ords() { ords(self) }
method trim-leading () { self.subst(/^ \s+/, "") }
method trim-trailing() { self.subst(/\s+ $/, "") }
method trim () { self.trim-leading.trim-trailing }
method EVAL() { EVAL(~self) }
method fmt(Str $format = '%s') {
sprintf($format, self);
}
method trans(*@changes) {
Niecza-trans(self, @changes);
}
method Set() {
my @keys;
for self.list() {
when Pair { @keys.push(.key) if .value; }
default { @keys.push($_) }
}
Set.new(@keys);
}
method SetHash() {
my @keys;
for self.list() {
when Pair { @keys.push(.key) if .value; }
default { @keys.push($_) }
}
SetHash.new(@keys);
}
method Bag() { Bag.new-from-pairs(self.list); }
method BagHash() { BagHash.new-from-pairs(self.list); }
}
my role Positional { Any }
my role Associative { Any }
my class Capture does Positional does Associative {
has $!positionals;
has $!named;
method Parcel() {
Q:CgOp { (box Parcel (getslot Capture $!positionals fvarlist (@ {self}))) }
}
method perl() {
self // return self.typename;
my $pos = self.Parcel.perl;
$pos = substr($pos, 2, chars($pos) - 3);
$pos = substr($pos, 0, chars($pos) - 2) if substr($pos, chars($pos) - 2, 2) eq ', ';
my $h := self.hash;
if $h {
$pos ~= ", " if $pos ne "";
$pos ~= "|" ~ $h.perl;
}
'\(' ~ $pos ~ ')';
}
method immutable() {
self // return True;
self.Parcel.immutable &&
(!self.hash || self.hash.values.Capture.Parcel.immutable);
}
method Capture () { self }
method item () {
if self.hash || self.Parcel.raw_elems != 1 {
die "Can only use .item on captures representing a single value"
}
self.Parcel.raw_at(0)
}
method list () { @(self.Parcel) }
method hash () { unitem( Q:CgOp {
(letn h (getslot Capture $!named varhash (@ {self}))
(ternary (== (l h) (null varhash)) {{}} (box Hash (l h))))
}) }
}
# }}}
# Scalar types {{{
my role Numeric is Cool {
method ACCEPTS(\t) {
defined(self) ?? (self == self ?? self == t !! t != t)
!! t.^does(self)
}
}
my role Real does Numeric {
method Bridge() {
self.Num;
}
method Complex() {
Q:CgOp { (complex_new {self.Bridge} {0}) };
}
method Str() {
self.Bridge.Str;
}
method Bool() {
self != 0;
}
method succ() {
self.Bridge + 1;
}
method pred() {
self.Bridge - 1;
}
}
my role Integral does Real { Any }
my class Num does Real {
method new() { 0e0 }
method immutable() { True }
multi method WHICH(Num:D:) { ObjAt.new(str => ~self, ref => self.WHAT) }
our constant pi = 3.14159_26535_89793_238e0;
our constant e = 2.71828_18284_59045_235e0;
our constant i = Q:CgOp { (complex_new {0} {1}) };
method Num() { self }
method FatRat() { self.Rat(0).FatRat }
method gist() { self.Str }
method perl() {
if defined(self) {
my $num = self.Str;
$num ~= 'e0' unless $num ~~ m:i/e/ || $num ~~ /Inf/ || $num ~~ /NaN/;
$num;
} else {
self.typename;
}
}
}
our constant pi = 3.14159_26535_89793_238e0;
our constant e = 2.71828_18284_59045_235e0;
our constant i = Num::i;
my class Int does Integral {
method new() { 0 }
method immutable() { True }
multi method WHICH(Int:D:) { ObjAt.new(str => ~self, ref => self.WHAT) }
method niecza_quantifier_max() { self }
method niecza_quantifier_min() { self }
method Bridge() { self.Num }
method Int() { self }
method perl() { defined(self) ?? ~self !! self.typename }
method FatRat() { FatRat.new(self, 1) }
method base(Cool $base) {
my $intBase = $base;
die("base must be between 2 and 36, got $base")
unless 2 <= $intBase <= 36;
my @conversion = 0..9, 'A' .. 'Z';
my @res;
my $n = self.abs;
repeat {
push @res, @conversion[$n % $intBase];
$n div= $intBase;
} while $n > 0;
push @res, '-' if self < 0;
join '', @res.reverse;
}
method expmod($power, $mod) { expmod(self, $power, $mod) }
method is-prime($tries = 100) { is-prime(self, $tries) }
method lsb() {
return Nil if self == 0;
Q:CgOp { (lsb {self.abs}) }
}
method msb() {
return Nil if self == 0;
return 0 if self == -1;
my $x = self < 0 ?? (self + 1) * -2 !! self;
Q:CgOp { (msb {$x}) }
}
}
sub Niecza::RatToStr ($rat, :$all) {
my $s = $rat.numerator < 0 ?? '-' !! '';
my $r = $rat.abs;
my $i = $r.floor;
$r -= $i;
$s ~= $i;
if $r {
$s ~= '.';
my $want = $all ?? Inf
!! $rat.denominator < 100_000
?? 6
!! $rat.denominator.Str.chars + 1;
sub CAN-HAZ-MOAR {
my $den = $r.denominator;
$den /= 2 while $den %% 2;
$den /= 5 while $den %% 5;
return False unless $den == 1;
$want = Inf;
return True;
}
my $f = '';
while $r and ($f.chars < $want || CAN-HAZ-MOAR) {
$r *= 10;
$i = $r.floor;
$f ~= $i;
$r -= $i;
}
$f++ if 2 * $r >= 1;
$s ~= $f;
}
$s;
}
my class Rat does Real {
method new($n,$d) { $n / $d }
method immutable() { True }
multi method WHICH(Rat:D:) { ObjAt.new(str => self.perl, ref => self.WHAT) }
multi method Str() { defined(self) ?? Niecza::RatToStr(self) !! "self.typename" }
method perl() {
return self.typename if !defined(self);
my $den = self.denominator;
$den /= 2 while $den %% 2;
$den /= 5 while $den %% 5;
if $den == 1 {
my $str = Niecza::RatToStr(self, :all);
$str ~= ".0" unless $str ~~ /\./;
$str;
} else {
"<" ~ self.numerator ~ "/" ~ self.denominator ~ ">";
}
}
method gist() { self // nextsame; self.Str }
method numerator() { Q:CgOp { (rat_nu {self}) } }
method denominator() { Q:CgOp { (rat_de {self}) } }
method Rat($eps = 1e-6) { self } #OK
method FatRat() { FatRat.new(self.numerator, self.denominator) }
method nude() { [ self.numerator, self.denominator ] }
method norm() { self }
}
my class Complex does Numeric {
method new($re,$im) { Q:CgOp { (complex_new {$re} {$im}) } }
method immutable() { True }
multi method WHICH(Complex:D:) { ObjAt.new(str => self.perl, ref => self.WHAT) }
method perl() { defined(self) ?? "<" ~ self ~ ">" !! self.typename }
method gist() { self // nextsame; self.Str }
method Complex() { self }
method re() { Q:CgOp { (complex_re {self}) } }
method im() { Q:CgOp { (complex_im {self}) } }
method conj() { self.re - (self.im)i }
method polar() { self.abs, atan2(self.im, self.re); }
}
my class FatRat does Real {
method new($n,$d) { FatRat.succ * $n / $d }
method immutable() { True }
multi method WHICH(FatRat:D:) { ObjAt.new(str => self.perl, ref => self.WHAT) }
multi method Str() { defined(self) ?? Niecza::RatToStr(self) !! "self.typename" }
method perl() { defined(self) ?? "FatRat.new({self.numerator}, {self.denominator})" !! self.typename }
method FatRat() { self }
method gist() { self // nextsame; self.Str }
method numerator() { Q:CgOp { (fatrat_nu {self}) } }
method denominator() { Q:CgOp { (fatrat_de {self}) } }
method nude() { [ self.numerator, self.denominator ] }
}
my class Buf { ... }
my class Str is Cool {
method new() { "" }
method immutable() { True }
method ACCEPTS(\t) { defined(self) ?? self eq t !! t.^does(self) }
method chars() { chars(self) }
method IO() { IO.new(path => self) }
method path() { IO::Path.new(self) }
method say() { $*OUT.say(self) }
multi method WHICH(Str:D:) {
ObjAt.new(str => ("str|" ~ self), ref => self.WHAT)
}
# TODO: Switch to a multi once where is working.
method indent($steps) {
my $TABSTOP = CALLER::<$?TABSTOP> // 8;
if $steps~~Int && $steps == 0 {
# Zero indent does nothing
return self;
} elsif $steps~~Int && $steps > 0 {
# Positive indent does indent
# We want to keep trailing \n so we have to .comb explicitly instead of .lines
return self.comb(/:r ^^ \N* \n?/).map({
given $_ {
# Use the existing space character if they're all the same
# (but tabs are done slightly differently)
when /^(\t+) ([ \S .* | $ ])/ {
$0 ~ "\t" x ($steps div $TABSTOP) ~
' ' x ($steps mod $TABSTOP) ~ $1
}
when /^(\h) $0* [ \S | $ ]/ {
$0 x $steps ~ $_
}
# Otherwise we just insert spaces after the existing leading space
default {
($_ ~~ /^(\h*) (.*)$/).join(' ' x $steps)
}
}
}).join;
} else {
# Negative values and Whatever-* do outdent
# Loop through all lines to get as much info out of them as possible
my @lines = self.comb(/:r ^^ \N* \n?/).map({
# Split the line into indent and content
my ($indent, $rest) = @($_ ~~ /^(\h*) (.*)$/);
# Split the indent into characters and annotate them
# with their visual size
my $indent-size = 0;
my @indent-chars = $indent.comb.map(-> $char {
my $width = $char eq "\t"
?? $TABSTOP - ($indent-size mod $TABSTOP)
!! 1;
$indent-size += $width;
$char => $width;
});
{ :$indent-size, :@indent-chars, :$rest };
});
# Figure out the amount * should outdent by, we also use this for warnings
my $common-prefix = [min] @lines.map({ $_<indent-size> });
# Set the actual outdent amount here
my Int $outdent = $steps ~~ Whatever ?? $common-prefix
!! -$steps;
warn sprintf('Asked to remove %d spaces, ' ~
'but the shortest indent is %d spaces',
$outdent, $common-prefix) if $outdent > $common-prefix;
# Work backwards from the right end of the indent whitespace, removing
# array elements up to # (or over, in the case of tab-explosion)
# the specified outdent amount.
@lines.map({
my $pos = 0;
while $_<indent-chars> and $pos < $outdent {
$pos += $_<indent-chars>.pop.value;
}
$_<indent-chars>».key.join ~ ' ' x ($pos - $outdent) ~ $_<rest>;
}).join;
}
}
method gist() { defined(self) ?? self !! nextsame }
method Numeric () { Niecza::NumSyntax.str2num(~self) }
CHECK my $esc = {
'$' => '\$', '@' => '\@', '%' => '\%', '&' => '\&', '{' => '\{',
"\b" => '\b', "\n" => '\n', "\r" => '\r', "\t" => '\t', '"' => '\"',
'\\' => '\\\\' };
method perl() {
self // nextsame;
'"' ~ self.subst(/ <[$@%&{\b\cJ\cM\t\"\\]> /, { $esc{$/} }, :g)\
.subst(/ <-print> /, { ord($/).fmt('\x[%x]') }, :g) ~ '"'
}
method encode(Str $enc) {
Q:CgOp { (box (@ {Buf}) (encode (unbox str (@ {self})) (obj_getstr {$enc}))) }
}
}
my class Buf {
method decode(Str $enc) {
Q:CgOp { (box Str (decode (unbox blob (@ {self})) (obj_getstr {$enc}))) }
}
method elems() {
Q:CgOp { (box Int (unbox blob (@ {self}))) }
}
method bytes() { self.elems }
method Bool() { ?self.elems }
method Numeric() { self.elems }
method Int() { self.elems }
}
# ObjAt in Niecza is the type of return values from WHICH. It is a comparable
# type that allows any two objects to be compared, and attempts to capture a
# notion of 'essential equality'. The most ready way to compare the identities
# of mutable objects is to compare references, so ObjAt keeps a reference;
# ObjAt also keeps a string description of contents, for non-mutable types.
#
# For mutable types, the string should be empty, and the reference should be
# the specific object that WHICH was invoked upon.
#
# For defined values of immuable types, the string should hold a description
# of this object, and the reference points to the WHAT of the invokee.
#
# Note that if this protocol is followed, $x === $y implies
# $x.WHAT === $y.WHAT, and so the string data is completely under the control
# of the type.
#
# Well, not quite - you need to avoid returning anything starting with objat|
my class ObjAt {
has Str $.str;
has Mu $.ref;
multi method WHICH(ObjAt:D:) {
ObjAt.new(str => 'objat|' ~ $!str, ref => $!ref)
}
sub REFHASH($v) { Q:CgOp { (box Int (ref_hash (@ {$v}))) }.fmt('[%X]') }
method Str() { self // nextsame; $!str ~ REFHASH($!ref) }
method gist() { self // nextsame; $!str ~ REFHASH($!ref) }
}
my class Scalar {
}
# just a tag
my role Callable { Any }
my class Code does Callable {
has $!outer;
has $!info;
method outer() { Q:CgOp { (getslot Code $!outer frame (@ {self})) } }
method perl() { defined(self) ?? '{ ... }' !! self.typename }
method accepts_capture($cap) { Q:CgOp { (code_accepts_capture (@ {self}) (@ {$cap})) } }
method candidates(Code:D:) { Q:CgOp { (code_candidates (@ {self})) } }
method signature(Code:D:) { Q:CgOp { (code_signature (@ {self})) } }
method candidates_matching(|cap) { grep *.accepts_capture(cap), self.candidates }
method name(Code:D:) { Q:CgOp { (box Str (code_name (@ {self}))) } }
}
my class Block is Code {
method ACCEPTS(\t) { defined(self) ?? (self)(t) !! t.^does(self) }
method count() { Q:CgOp { (count (@ {self})) } }
method arity() { Q:CgOp { (arity (@ {self})) } }
}
my class Routine is Block {
method assuming(|cap) { sub (|new) { self.(|cap, |new) } }
# wrap, unwrap, cando NYI
method perl() {
self // nextsame;
my $perl = self.^name.lc();
if self.name() -> $n {
$perl ~= " $n";
}
$perl ~= self.signature().perl.substr(1);
$perl ~= ' { ... }';
$perl
}
}
my class Sub is Routine { }
my class Method is Routine { }
my class Submethod is Routine { }
my class WhateverCode is Block { }
my class Parameter {
# Value processing
our constant HASTYPE = 1;
our constant MULTI_IGNORED = 16384;
our constant ANY_DEF = 0x40000;
our constant UNDEF_ONLY = 0x80000;
our constant DEF_ONLY = 0xC0000;
our constant TYPE_ONLY = 0x100000;
our constant DEF_MASK = 0x1C0000;
# Value binding
our constant READWRITE = 2;
our constant RWTRANS = 8;
our constant INVOCANT = 8192;
our constant IS_COPY = 32768;
our constant IS_LIST = 65536;
our constant IS_HASH = 131072;
our constant CALLABLE = 0x20_0000;
# Value source
our constant HASDEFAULT = 32;
our constant OPTIONAL = 64;
our constant DEFOUTER = 4096;
our constant POSITIONAL = 128;
our constant SLURPY_POS = 256;
our constant SLURPY_NAM = 512;
our constant SLURPY_CAP = 1024;
our constant SLURPY_PCL = 2048;
method flags(Parameter:D:) { Q:CgOp { (box Int (param_flags (@ {self}))) } }
method named(Parameter:D:) { ? (self.named_names && !self.positional) }
method named_names(Parameter:D:) { Q:CgOp { (param_names (@ {self})) } }
method type(Parameter:D:) { Q:CgOp { (param_type (@ {self})) } }
method sub_signature(Parameter:D:) { Q:CgOp { (param_subsig (@ {self})) } }
method optional(Parameter:D:) { ?( self.flags +& (HASDEFAULT +| OPTIONAL) ) }
method positional(Parameter:D:) { ?( self.flags +& POSITIONAL ) }
## method value_constraint_list() { !!! }
method name() { Q:CgOp { (box Str (param_name (@ {self}))) } }
method slurpy() { ?( self.flags +& (SLURPY_CAP + SLURPY_NAM + SLURPY_POS) ) }
# no constraint_list! niecza's SubInfo constraints don't reflect well :|
method value_constraint_list(Parameter:D:) { Q:CgOp { (param_value_constraints (@ {self})) } }
method parcel() { ?( self.flags +& RWTRANS ) }
method capture() { ?( self.flags +& SLURPY_CAP ) }
method rw() { ?( self.flags +& READWRITE ) }
method copy() { ?( self.flags +& IS_COPY ) }
method readonly() { !( self.flags +& (READWRITE + IS_COPY + RWTRANS) ) }
method invocant() { ?( self.flags +& INVOCANT ) }
## method default() { }
# XXX TODO: A few more bits :-)
multi method perl(Parameter:D:) {
my $perl = '';
my $flags = self.flags;
my $type = self.type.^name;
if $flags +& IS_LIST {
# XXX Need inner type
}
elsif $flags +& IS_HASH {
# XXX Need inner type
}
else {
$perl = $type;
if $flags +& DEF_ONLY {
$perl ~= ':D';
} elsif $flags +& UNDEF_ONLY {
$perl ~= ':U';
} elsif $flags +& TYPE_ONLY {
$perl ~= ':T';
}
$perl ~= ' ';
}
if self.name -> $name is copy {
if $flags +& SLURPY_CAP {
$perl ~= '|' ~ $name;
} elsif $flags +& RWTRANS {
$perl ~= '\\' ~ $name;
} else {
my $default = $flags +& HASDEFAULT;
if !self.positional && self.named_names -> @names {
my $short = $name.substr(1);
$name = ':' ~ $name if $short eq any @names;
for @names {
next if $_ eq $short;
$name = ':' ~ $_ ~ '(' ~ $name ~ ')';
}
$name ~= '!' unless self.optional;
} elsif self.optional && !$default {
$name ~= '?';
} elsif self.slurpy {
$name = '*' ~ $name;
}
$perl ~= $name;
if $flags +& READWRITE {
$perl ~= ' is rw';
} elsif $flags +& IS_COPY {
$perl ~= ' is copy';
}
$perl ~= ' = { ... }' if $default;
if self.sub_signature -> $sub {
$perl ~= ' ' ~ $sub.perl;
}
}
}
$perl
}
}
my class Signature {
method params(Signature:D:) { Q:CgOp { (sig_params (@ {self})) } }
method arity(Signature:D:) { Q:CgOp { (box Int (sig_arity (@ {self}))) } }
method count(Signature:D:) { Q:CgOp { (box Int (sig_count (@ {self}))) } }
# XXX TODO: Parameter separators.
method perl() {
self // nextsame;
':(' ~ join(', ', self.params».perl) ~ ')';
}
}
my class ClassHOW {
method name($) { Q:CgOp { (box Str (obj_typename (stab_what (unbox stable (@ {self}))))) } }
method isa(\obj, \type) { Q:CgOp {
(box Bool (obj_isa (@ {obj}) (obj_llhow (@ {type}))))
} }
method does(\obj, \role) { self.isa(obj, role) }
method can(\obj, $name) { Q:CgOp {
(box Bool (obj_can (@ {obj}) (obj_getstr {$name})))
} }
}
my role CommonEnum {
has $!index;
method perl() {
defined(self) ?? (self.typename ~ "::" ~ self.key) !! self.typename
}
method gist() { defined(self) ?? self.key !! ("(" ~ self.typename ~ ")") }
method key() { self.enums._index_to_key($!index) }
method value() { self.enums._index_to_value($!index) }
method kv() { self.key, self.value }
method pair() { self.key => self.value }
method succ() {
my $index = defined(self) ?? $!index !! 0;
return self if $index == self.enums - 1;
self.from-index($index + 1)
}
method pred() {
my $index = defined(self) ?? $!index !! 0;
$index ?? self.from-index($index - 1) !! self;
}
method from-index($ix) { self._create($ix,self.enums._index_to_value($ix)) }
method postcircumfix:<( )> ($key) {
self.from-index(self.enums._lookup($key));
}
method pick($count = 1) { self.enums.map({ self.($_.key) }).pick($count) }
method roll($count = 1) { self.enums.map({ self.($_.key) }).roll($count) }
}
my role IntBasedEnum does CommonEnum {
method Numeric() { Q:CgOp { (box Int (unbox int (@ {self}))) } }
method Int() { self.Numeric }
method Str() { defined(self) ?? self.key !! nextsame }
method Stringy() { defined(self) ?? self.key !! nextsame }
method _create($ix,$val) { Q:CgOp {
(letn obj (box (@ {self}) (unbox int (@ {$val.Int})))
(setslot (obj_llhow (@ (l obj))) $!index (@ (l obj)) {$ix.Int})
(l obj))
} }
}
my role StrBasedEnum does CommonEnum {
method _create($ix,$val) { Q:CgOp {
(letn obj (box (@ {self}) (unbox str (@ {$val.Str})))
(setslot (obj_llhow (@ (l obj))) $!index (@ (l obj)) {$ix.Int})
(l obj))
} }
}
# Using the "enum" type declarator would require a compile time reference
# to the EnumMap type, which depends on Bool; ick.
my class Bool is Int does IntBasedEnum {
our $_enums;
method enums() { $_enums }
our constant True = Q:CgOp { (box Bool (bool 1)) };
our constant False = Q:CgOp { (box Bool (bool 0)) };
method ACCEPTS(\t) { defined(self) ?? self !! t.^does(self) }
method succ() { True }
method pred() { False }
}
# }}}
# Fundamental scalar operators {{{
sub infix:<~> is Niecza::absprec<r= list> is pure is Niecza::builtin('concat', 0) (\|$bits) {
Q:CgOp { (concat (unbox fvarlist (@ {$bits}))) }
}
sub infix:<max>(*@values) is pure is Niecza::absprec<k= list> { @values.max }
sub infix:<min>(*@values) is pure is equiv<max> { @values.min }
sub infix:<minmax>(*@values) is equiv<max> { @values.minmax }
sub warn($str) { Q:CgOp { (control 11 (null frame) (int -1) (obj_getstr {$str}) (null obj)) } }
sub gist(\|@items) { @items.gist }
our sub Niecza::gistcat(\|@items) {
my @tok;
loop (my $i = 0; $i < @items.raw_elems; $i++) {
push @tok, @items.raw_at($i).gist;
}
@tok.join;
}
sub say(|c) { $PROCESS::OUTPUT_USED := True; Q:CgOp { (rnull (say (obj_getstr {Niecza::gistcat(|c)}))) }; True }
sub print(*@items) { $PROCESS::OUTPUT_USED := True; Q:CgOp { (rnull (print (obj_getstr {@items.join("")}))) }; True }
sub note(|c) { $PROCESS::OUTPUT_USED := True; Q:CgOp { (rnull (note (obj_getstr {Niecza::gistcat(|c)}))) }; True }
sub sprintf(\|$args) { Q:CgOp { (sprintf (unbox fvarlist (@ {$args}))) } }
sub printf(Cool $format, *@args) { print sprintf $format, |@args };
sub exit($status = 0) { Q:CgOp {
(rnull [exit (cast int (obj_getnum {$status}))])
} }
sub index($haystack,$needle,$pos?) is pure { $haystack.index($needle,$pos) }
sub rindex($haystack,$needle,$pos?) is pure { $haystack.rindex($needle,$pos) }
sub comb($matcher,$str,$limit?,:$match) { (~$str).comb($matcher,$limit,:$match) }
sub split($matcher,$str,$limit?,:$all) { (~$str).split($matcher,$limit,:$all) }
sub item(Mu $x) { $x }
sub list(*@x) { @x.list }
sub prefix:<not> is pure is Niecza::absprec<h= unary left> (\x) { not(x) }
sub infix:<x> is pure is Niecza::absprec<s=> ($str, $ct) {
my $i = +$ct;
my @j;
while $i >= 1 {
$i--;
push @j, $str;
}
@j.join;
}
sub infix:<leg> is pure is Niecza::absprec<n= non> is diffy ($s1, $s2) {
(Q:CgOp { (box Num (cast num (strcmp (obj_getstr {$s1}) (obj_getstr {$s2})))) }) <=> 0
}
sub lc($string) is pure { (~$string).lc }
sub uc($string) is pure { (~$string).uc }
sub tc($string) is pure { (~$string).tc }
sub tclc($string) is pure { (~$string).tclc }
sub chop($string) is pure { (~$string).chop }
sub chomp($string) is pure { (~$string).chomp }
sub wordcase($string) is pure { (~$string).wordcase }
sub p5chop(*@strs) { my $r = ''; $r = .p5chop for @strs; $r }
sub p5chomp(*@strs) { my $r = 0; $r += .p5chomp for @strs; $r }
sub flip($string) is pure { (~$string).flip }
sub lcfirst($o) is pure { my $s = ~$o; lc(substr($s,0,1)) ~ substr($s,1) }
sub trim-leading($string) is pure { $string.trim-leading };
sub trim-trailing($string) is pure { $string.trim-trailing };
sub trim($string) is pure { $string.trim };
sub Niecza::ValueIdentity(Mu $l, Mu $r) {
my $lw = $l.WHICH;
my $rw = $r.WHICH;
Q:CgOp { (box Bool (compare == (@ {$lw.ref}) (@ {$rw.ref}))) } &&
$lw.str eq $rw.str
}
sub infix:<===>($l, $r) is equiv<==> { Niecza::ValueIdentity($l, $r) }
sub infix:<=:=>(\l,\r) is equiv<==> { Q:CgOp {
(box Bool (compare == {l} {r}))
} }
sub _param_role_inst(\|$t) {
Q:CgOp { (instrole (unbox fvarlist (@ {$t}))) }
}
sub infix:<does>($obj, \roles, :$clone, :$value) is rw {
die "Cannot use 'does' operator with a type object"
if !$clone && !$obj.defined;
die "Cannot use 'does' operator with an immutable object"
if !$clone && $obj.immutable;
$obj := $obj.clone if $clone && defined($obj);
my Mu $newtype;
my @roles = roles;
for @roles <-> $val {
my $oval = $val;
if defined($val) {
$val = Q:CgOp { (enum_mixin_role (obj_getstr {$val.typename})
(@ {method () { $oval }})) };
} elsif !Q:CgOp { (is_role {$val}) } {
my $tn = $val.typename;
$val = Q:CgOp { (type_mixin_role {$val}
{method () { Q:CgOp { (dyngetattr {self} {$newtype} {$tn}) } } }) };
}
}
Q:CgOp { (mixin (@ {$obj}) {@roles} {$value} {$newtype}) }
}
sub infix:<but>($obj, \roles, :$value) is rw {
infix:<does>($obj, roles, :clone, :$value)
}
sub infix:<~~>($t,$m) is equiv<==> { $m.ACCEPTS($t) }
sub ord($x) is pure { Q:CgOp { (ord {$x}) } }
sub chr($x) is pure { Q:CgOp { (chr {$x}) } }
sub ords($x) { $x.comb.map({ ord($_) }) }
sub chrs(*@x) { @x.map({ chr($_ )}).join }
# }}}
# Flow inspection and control {{{
my class CallFrame {
method caller() { Q:CgOp {
(letn c (frame_caller (cast frame (@ {self})))
(ternary
(!= (l c) (null frame))
(l c)
{Any}))
} }
method dynamic-caller() { Q:CgOp {
(letn c (frame_dyn_caller (cast frame (@ {self})))
(ternary
(!= (l c) (null frame))
(l c)
{Any}))
} }
method file() { Q:CgOp { (box Str (frame_file
(cast frame (@ {self})))) } }
method line() { Q:CgOp { (box Num (cast num (frame_line
(cast frame (@ {self}))))) } }
method subname() { Q:CgOp { (box Str (frame_subname
(cast frame (@ {self})))) } }
method args() { Q:CgOp { (frame_args (cast frame (@ {self}))) } }
method hints($var) { Q:CgOp { (frame_hint (cast frame (@ {self}))
(obj_getstr {$var})) } }
}
sub caller() { Q:CgOp { (frame_caller (frame_caller (callframe))) } }
sub callframe(Int $level is copy = 0) {
my $frame := Q:CgOp { (frame_caller (callframe)) };
$frame := $frame.caller while $level--;
$frame;
}
sub die($msg = "Died") { Q:CgOp { (die (@ {$msg})) } }
my class Label {
has $!target;
has $!name;
method immutable() { True }
method goto() { _lexotic(8, self, ()) }
method next() { _lexotic(1, self, ()) }
method last() { _lexotic(2, self, ()) }
method redo() { _lexotic(3, self, ()) }
}
# XXX multi dispatch
sub _lexotic ($id, $x, \val) {
Q:CgOp {
(letn fr (null frame)
nm (null str)
id (@ {$x})
(ternary (obj_isa (l id) (class_ref mo Label))
(prog (l fr (getslot Label $!target frame (l id)))
(l nm (getslot Label $!name str (l id))))
(ternary (obj_isa (l id) (class_ref mo Str))
(l nm (obj_getstr {$x}))
(prog)))
(control (cast int (obj_getnum {$id})) (l fr) (int -1) (l nm) {val}))
}
}
sub goto ($x) { _lexotic(8, $x, ()) }
sub nextsame() {
Q:CgOp { (control 9 (null frame) (int -1) (null str) (null obj)) }
}
sub nextwith(|cap) {
Q:CgOp { (control 9 (null frame) (int -1) (null str) (@ {cap})) }
}
sub callsame () { Q:CgOp { (callnext (null obj)) } }
sub callwith (|cap) { Q:CgOp { (callnext (@ {cap})) } }
sub assignop($fn) {
anon sub _assign(\lhs, \rhs) {
lhs = $fn(lhs, rhs)
}
}
sub notop(&fn) { -> \x, \y { !(fn(x,y)) } }
# }}}
# Aggregate types {{{
# Parcel: immutable list of boxes which have no context - may flatten, may
# autovivify, don't rebind or push/shift/etc
# List: mutable list of boxes without much context. accessing off end returns
# undefined. lazy.
# coercion makes the elements of a List read-only and maybe fetches them too.
# Array: mutable list of read-write scalar boxes
sub unitem(\a) { Q:CgOp { (newrwlistvar (@ {a})) } }
sub head(\x) { for x -> \elt { return elt }; Any }
my class Iterator {
method list () {
Q:CgOp {
(letn n (obj_newblank (class_ref mo List))
(iter_to_list (l n) (unbox vvarlist (@ {self})))
(newrwlistvar (l n)))
}
}
method flat () {
Q:CgOp {
(letn n (obj_newblank (class_ref mo List))
(iter_to_list (l n) (iter_flatten (unbox vvarlist (@ {self}))))
(newrwlistvar (l n)))
}
}
}
my class IterCursor {
# subclasses must provide .reify, return parcel
}
sub flat(*@x) { @x }
sub hash(|cap) {
(%(cap) || cap.Parcel.raw_elems != 1) ??
%( @(cap), %(cap) ) !! %( $(cap) )
}
my class EMPTY { }
my class Parcel is Cool does Positional {
method ACCEPTS(\what) { defined(self) ?? self.flat.ACCEPTS(what) !! nextsame }
method flat() { self.iterator.flat }
method at_pos($key) { @(self).[$key] }
# LoLly usage
method raw_elems() { Q:CgOp {
(box Num (cast num (fvarlist_length (unbox fvarlist (@ {self})))))
} }
method raw_at($ix) {
Q:CgOp { (fvarlist_item (cast int (obj_getnum {$ix})) (unbox fvarlist (@ {self}))) }
}
method immutable() {
self // return True;
my $ix = 0;
my $max := self.raw_elems;
while $ix < $max {
IMMUTABLE(self.raw_at($ix++)) || return False;
}
True;
}
method unwrap-single(@self:) { Q:CgOp {
(letn p (unbox fvarlist (@ {@self}))
l (fvarlist_length (l p))
(ternary (== (i 0) (l l)) {Nil}
(ternary (== (i 1) (l l))
(fvarlist_item (i 0) (l p)) {@self})))
} }
method Capture () {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {Capture})))
(setslot Capture $!positionals (l n) (unbox fvarlist (@ {self})))
(l n))
}
}
method perl(\:) {
self // return self.typename;
my @tok;
push @tok, '$' if !self.flattens;
push @tok, '(';
loop (my $i = 0; $i < self.raw_elems; $i++) {
push @tok, self.raw_at($i).perl;
push @tok, ', ' unless $i == self.raw_elems - 1 && $i;
}
push @tok, ')';
@tok.join;
}
method elems () { + @(self) }
method Numeric() { + @(self) }
method Bool () { ? @(self) }
method gist () {
self // nextsame;
my @tok;
loop (my $i = 0; $i < self.raw_elems; $i++) {
push @tok, self.raw_at($i).gist;
}
@tok.join(" ");
}
method Array () { my @a = @(self); @a; }
method fmt($format = '%s', $separator = ' ') { # duplicates version in List
self.map({ .fmt($format) }).join($separator);
}
}
my class List is Cool does Positional {
has $!items;
has $!rest;
has $!flat;
method new() {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {self})))
(setslot List $!items (l n) (vvarlist_new_empty))
(setslot List $!rest (l n) (vvarlist_new_empty))
(newrwlistvar (l n)))
};
}
method flat() {
self.iterator.flat
}
method Seq () {
Q:CgOp { (box Iterator (iter_copy_elems (unbox vvarlist (@ {self.eager.iterator})))) }.list
}
method clone() { Q:CgOp {
(letn selfo (@ {self})
new (obj_newblank (obj_llhow (l selfo)))
(setslot List $!items (l new) (vvarlist_clone
(getslot List $!items vvarlist (l selfo))))
(setslot List $!rest (l new) (vvarlist_clone
(getslot List $!rest vvarlist (l selfo))))
(newrwlistvar (l new)))
} }
method Capture () {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {Capture})))
(setslot Capture $!positionals (l n) (vvarlist_to_fvarlist
(getslot List $!items vvarlist (@ {self.eager}))))
(l n))
}
}
method perl(\:) {
self // return self.typename;
my @tok;
push @tok, '(';
push @tok, .perl, ', ' for @(self);
pop @tok if @tok >= 5;
push @tok, ').list';
push @tok, '.item' if !self.flattens;
@tok.join
}
method eager() { +self; self }
method head() { self ??
Q:CgOp { (vvarlist_item (i 0) (getslot List $!items vvarlist (@ {self}))) } !!
Any
}
method elems() { +self }
method join($sep = '') { Q:CgOp { (list_join {$sep} {unitem(self)}) } }
method ACCEPTS(\topic) {
self // nextsame;
my @t = topic.list;
# TODO: Whatever-DWIMmery
return False unless self.elems == @t.elems;
for ^self.elems {
return False unless self.at_pos($_) === @t[$_];
}
True;
}
method gist() { defined(self) ?? self.map(*.gist).join(" ") !! nextsame }
method Array () { my @a = @(self); @a; }
method sort($cmp_ = &infix:<cmp>) {
my $cmp = $cmp_;
if $cmp_.count == 1 {
$cmp = sub (\x, \y) { $cmp_(x) cmp $cmp_(y) }
}
my $l = @(self).eager;
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {List})))
(setslot List $!items (l n) (vvarlist_sort (@ {$cmp})
(getslot List $!items vvarlist (@ {$l}))))
(setslot List $!rest (l n) (vvarlist_new_empty))
(newrwlistvar (l n)))
}
}
method reverse() { reverse( @(self) ); }
method categorize ($test) { {}.categorize( $test, self.list ) }
method classify ($test) { {}.classify( $test, self.list ) }
method min($cmp_ = &infix:<cmp>) {
my $cmp = $cmp_;
if $cmp_.count == 1 {
$cmp = sub (\x, \y) { $cmp_(x) cmp $cmp_(y) }
}
my $min = self[0] // return Inf;
for @(self) {
$min = $_ if $cmp($_, $min) < 0;
}
$min;
}
method max($cmp_ = &infix:<cmp>) {
my $cmp = $cmp_;
if $cmp_.count == 1 {
$cmp = sub (\x, \y) { $cmp_(x) cmp $cmp_(y) }
}
my $max = self[0] // return -Inf;
for @(self) {
$max = $_ if $cmp($_, $max) > 0;
}
$max;
}
method minmax($cmp_ = &infix:<cmp>) {
my $cmp = $cmp_;
if $cmp_.count == 1 {
$cmp = sub (\x, \y) { $cmp_(x) cmp $cmp_(y) }
}
my $min = self[0] // return Inf .. -Inf;
my $max = self[0];
for @(self) {
$min = $_ if $cmp($_, $min) < 0;
$max = $_ if $cmp($_, $max) > 0;
}
$min..$max;
}
method plan(*@items) {
Q:CgOp {
(rnull
(vvarlist_append (getslot List $!rest vvarlist (@ {self}))
(unbox vvarlist (@ {@items.iterator}))))
}
}
method kv() { my $i = 0; self.map({ $i++, $_ }) }
method at_pos($p) { self[$p] }
method fmt($format = '%s', $separator = ' ') {
self.map({ .fmt($format) }).join($separator);
}
method rotate($n = 1) {
my $k = $n % self.elems;
self[$k .. self.elems-1, 0 .. $k-1];
}
method splice( @array is rw: $offset = 0, $size = Inf, *@values ) {
my $begin = $offset.^does(Code) ?? $offset.(@array.elems) !! $offset;
my $max;
if $size.^does(Code) {
$max = $size.(@array.elems);
} elsif $size < 0 {
die '$size must be non-negative.';
} else {
$max = $begin + $size;
}
if $max > @array.elems {
$max = @array.elems;
}
if ($begin < 0) {
die '$offset must be non-negative.';
}
if ($max < 0) {
die '$size must be non-negative.';
}
my @retval = @array.delete($begin..^$max);
my @temp = @array[0..^$begin];
@temp.push(@values);
@temp.push(@array[$max..^@array.elems]);
@array = @temp;
return @retval;
}
}
my class Array is List {
method perl(\:) {
self // return self.typename;
"[" ~ self.map(*.perl).join(', ') ~ "]" ~ (self.flattens ?? ".list" !! "");
}
method delete(*@indices) {
my @result;
my @i = @indices.map({
when Range { $_.iterator.list }
when Callable { $_(+self) }
when * < 0 { die "Negative index not allowed, please use WhateverCode" }
$_;
});
for @i -> $i {
@result.push(self[$i]);
self[$i] = Any;
}
self.pop while ?self && !defined self[*-1];
return @result;
}
}
# Not connected to Hash because Stash contains bvalues while Hash
# holds values directly.
my class Stash does Associative {
method at_key($key) {
Q:CgOp { (stash_at_key (@ {self}) (obj_getstr {$key})) } }
method bind_key($key, \to) {
Q:CgOp { (stash_bind_key (@ {self}) (obj_getstr {$key}) {to}) } }
method delete_key($key) {
Q:CgOp { (stash_delete_key (@ {self}) (obj_getstr {$key})) } }
method exists_key($key) {
Q:CgOp { (stash_exists_key (@ {self}) (obj_getstr {$key})) } }
}
my class PseudoStash does Associative {
has $.name;
method at_key($key) {
Q:CgOp { (pstash_at_key (@ {self}) (obj_getstr {$key})) } }
method bind_key($key, \to) {
Q:CgOp { (pstash_bind_key (@ {self}) (obj_getstr {$key}) {to}) } }
}
my class Hash does Associative {
method new() { unitem(Q:CgOp { (box Hash (varhash_new)) }) }
method any() { any self.keys }
method none() { none self.keys }
method all() { all self.keys }
method one() { one self.keys }
method Capture () {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {Capture})))
(setslot Capture $!positionals (l n) (fvarlist_new))
(setslot Capture $!named (l n) (varhash_dup
(unbox varhash (@ {self}))))
(l n))
}
}
method keys() { Q:CgOp { (hash_keys {self}) } }
method values() { Q:CgOp { (hash_values {self}) } }
method pairs() { Q:CgOp { (hash_pairs {self}) } }
method list() { Q:CgOp { (hash_pairs {self}) } }
method kv() { Q:CgOp { (hash_kv {self}) } }
method Set() { self.list.Set }
method SetHash() { self.list.SetHash }
method Bag() { self.list.Bag }
method BagHash() { self.list.BagHash }
method Numeric() { +@(self) }
method Str() { @(self).map(* ~ "\n").join }
method invert() {
my @new;
for self.kv -> $k, $v { push @new, $v => $k }
@new
}
method !array-push(Str $key, Mu $value) {
if not self{$key}:exists {
self{$key} = $value;
} elsif self{$key} ~~ Array {
self{$key}.push: $value;
} else {
self{$key} = [self{$key}, $value];
}
}
method push(*@v) {
my Mu $previous;
my $has_previous;
for @v -> $e {
if $has_previous {
self!array-push($previous.Str, $e);
$has_previous = 0;
} elsif $e.^isa(Enum) {
self!array-push($e.key.Str, $e.value);
} else {
$previous = $e;
$has_previous = 1;
}
}
self;
}
# proto method classify(|) { * }
multi method classify( &test, *@list ) {
for @list {
my $k = test($_);
self{$k} //= [];
self{$k}.push: $_;
}
self;
}
multi method classify( %test, *@list ) {
for @list {
my $k = %test{$_};
self{$k} //= [];
self{$k}.push: $_;
}
self;
}
multi method classify( @test, *@list ) {
for @list {
my $k = @test[$_];
self{$k} //= [];
self{$k}.push: $_;
}
self;
}
# proto method categorize(|) { * }
multi method categorize( &test, *@list ) {
for @list {
for test($_) -> $k {
self{$k} //= [];
self{$k}.push: $_;
}
}
self;
}
multi method categorize( %test, *@list ) {
for @list {
for %test{$_} -> $k {
self{$k} //= [];
self{$k}.push: $_;
}
}
self;
}
multi method categorize( @test, *@list ) {
for @list {
for @test[$_] -> $k {
self{$k} //= [];
self{$k}.push: $_;
}
}
self;
}
# Rakudo extensions compatibility - DO NOT USE
method delete($key) { self.{$key}:delete }
method exists($key) { self.{$key}:exists }
method at_key($key) { self.{$key} }
method exists_key($key) { self.{$key}:exists }
method delete_key($key) { self.{$key}:delete }
method perl(\:) {
self // return self.typename;
'{' ~ (self{self.keys.sort}:p).map(*.perl).join(', ') ~ '}' ~
(self.flattens ?? ".hash" !! "")
}
method fmt($format = "%s\t%s", $sep = "\n") {
self.pairs.map({ .fmt($format) }).join($sep)
}
method ACCEPTS($x) {
return $x.^does(self) unless self.defined;
sub contains-keys(%a, %b) {
for %a.keys -> $k { return False unless %b{$k}:exists; }
True;
}
given $x {
when Hash { contains-keys(self, $x) && contains-keys($x, self); }
when Array { self{any @$x}:exists; }
when Regex { any(self.keys).match($x); }
when Cool { self{$x}:exists; }
False;
}
}
}
my class Whatever {
method immutable() { True }
method ACCEPTS(\x) { defined(self) || x.^isa(Whatever) }
}
# XXX use an unshadowable name
BEGIN my $__Whatever := Q:CgOp { (blackhole {Whatever.new}) };
my class Enum is Cool {
has $.key;
has Mu $.value;
method Capture () {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {Capture})))
d (varhash_new)
(setslot Capture $!positionals (l n) (fvarlist_new))
(setslot Capture $!named (l n) (l d))
(varhash_setindex (obj_getstr {$!key})
(l d) {$!value})
(l n))
}
}
method immutable() {
self // return True;
IMMUTABLE($!key) || IMMUTABLE($!value);
}
method kv() {
($.key, $.value);
}
method perl() { defined(self) ?? (self.key.perl ~ ' => ' ~ self.value.perl) !! self.typename }
method pairs() {
self.flat;
}
}
my class Pair is Enum {
method ACCEPTS(\other) {
self // nextsame;
other.^does(Hash) ?? ($.value.ACCEPTS(other{$.key})) !!
(?$.value) == (?other.?"$.key"())
}
method Str() {
$.key ~ "\t" ~ $.value
}
method perl() {
if self.defined {
my $lp = "";
my $rp = "";
if self.key ~~ Pair {
$lp = "(";
$rp = ")";
}
$lp ~ self.key.perl ~ $rp ~ ' => ' ~ self.value.perl;
} else {
self.typename;
}
}
method invert() {
$.value => $.key
}
method fmt(Str $format = "%s\t%s") {
return sprintf($format, $.key, $.value);
}
}
# XXX This ought to be more read-only
my class EnumMap does Associative {
has %!by-key;
has %!by-value;
has @!values;
has @!keys;
has $.data-type;
method new(*@pairs) {
self := self.bless();
my $last = -1;
my $ixn = 0;
my $str;
my $int;
for @pairs -> $p {
my ($k, $v);
if $p ~~ Pair {
$k ::= ~$p.key;
$v ::= $p.value;
} else {
$k ::= ~$p;
$v ::= $last.succ;
}
if $v ~~ Int { $int = 1; }
elsif $v ~~ Str { $str = 1; }
else {
die "Enum values must be Int or Str, but got $v.typename()";
}
$last = $v;
%!by-key{$k} = $ixn;
%!by-value{$v} //= $ixn;
push @!keys, $k;
push @!values, $v;
$ixn++;
}
die "Enum must have at least one value" unless $int || $str;
die "Enum must contain integer or string values, not both" if $int && $str;
$!data-type := $int ?? 'Int' !! 'Str';
unitem(self);
}
method Numeric() { +@!keys }
method _index_to_key($i) { @!keys[$i] }
method _index_to_value($i) { @!values[$i] }
method _lookup($w) {
%!by-key{$w} // %!by-value{$w} // die "No match"
}
method iterator() { self.list.iterator }
method list() { @!keys Z=> @!values }
method hash() { %!by-key }
method keys() { @!keys }
method values() { @!values }
method invert() { @!values Z=> @!keys }
method kv() { @!keys Z @!values }
method pairs() { self.list }
method at_key(\k) { (my $ ::= @!values[%!by-key.{k}]) }
method exists_key($k) { self{$k}:exists }
}
BEGIN { $Bool::_enums ::= EnumMap.new("False" => 0, "True" => 1) }
my enum Order (:Less(-1), :Same(0), :More(1), :Decrease(-1), :Increase(1));
proto sub infix:<⊆>($, $ --> Bool) is equiv(&infix:<==>) {*}
proto sub infix:<≼>($, $ --> Bool) is equiv(&infix:<==>) {*}
role Baggy { Any }
class Set does Associative {
has Bool %!elems;
method default { False }
method keys { %!elems.keys }
method values { %!elems.values }
method elems returns Int { %!elems.elems }
method exists($a) returns Bool { %!elems.exists($a) }
method Bool { %!elems.Bool }
method Numeric { %!elems.Numeric }
method hash { %!elems.hash }
method Set { self }
method SetHash { SetHash.new(self.keys) }
method Bag { bag self.keys }
method BagHash { BagHash.new(self.keys) }
method at_key($k) { ?(%!elems{$k} // False) }
method exists_key($k) { self.exists($k) }
# Constructor
method new(*@args --> Set) {
my %e;
for @args {
%e{$_} = True;
}
self.bless(:elems(%e));
}
submethod BUILD (%!elems) { }
method ACCEPTS($other) { defined(self) ?? $other ⊆ self && self ⊆ $other !! $other.^does(self) }
method Str() { self.defined ?? %!elems.keys().join(" ") !! nextsame }
method gist() { self.defined ?? "set({ %!elems.keys».gist.join(', ') })" !! "(Set)" }
method perl() { self.defined ?? 'Set.new(' ~ join(', ', map { .perl }, %!elems.keys) ~ ')' !! "Set" }
method iterator() { %!elems.keys.iterator }
method list() { %!elems.keys }
method pick($count = 1) { %!elems.keys.pick($count) }
method roll($count = 1) { %!elems.keys.roll($count) }
# TODO: WHICH will require the capability for >1 pointer in ObjAt
}
# Set operators
sub set(*@args --> Set) {
Set.new(@args);
}
constant term:<∅> = set();
proto sub infix:<∈>($, $ --> Bool) is equiv(&infix:<==>) {*}
multi sub infix:<∈>($a, Any $b --> Bool) { $a ∈ $b.Set }
multi sub infix:<∈>($a, Set $b --> Bool) { $b.exists($a) }
only sub infix:<(elem)>($a, $b --> Bool) is iffy { $a ∈ $b }
only sub infix:<∉>($a, $b --> Bool) is equiv(&infix:<==>) { $a !∈ $b }
proto sub infix:<∋>($, $ --> Bool) is equiv(&infix:<==>) {*}
multi sub infix:<∋>(Any $a, $b --> Bool) { $a.Set ∋ $b }
multi sub infix:<∋>(Set $a, $b --> Bool) { $a.exists($b) }
only sub infix:<(cont)>($a, $b --> Bool) is iffy { $a ∋ $b }
only sub infix:<∌>($a, $b --> Bool) is equiv(&infix:<==>) { $a !∋ $b }
only sub infix:<∪>(\|$p) is equiv(&infix:<|>) {
my $set = Set.new: $p.map(*.Set.keys);
if $p.grep(Baggy) {
my @bags = $p.map(*.Bag);
Bag.new-from-pairs($set.map({ ; $_ => [max] @bags>>.{$_} }));
} else {
$set;
}
}
only sub infix:<(|)>(\|$p) is equiv(&infix:<|>) { infix:<∪>(|$p) }
only sub infix:<∩>(\|$p) is equiv(&infix:<&>) {
my $base_set = $p ?? $p[0].Set !! ∅;
if $p.grep(Baggy) {
my @bags = $p.map(*.Bag);
Bag.new-from-pairs($base_set.map({ ; $_ => [min] @bags>>.{$_} }));
} else {
my @sets = $p.map(*.Set);
Set.new($base_set.grep: -> $k { @sets>>.{$k}.all });
}
}
only sub infix:<(&)>(\|$p) is equiv(&infix:<&>) { infix:<∩>(|$p) }
only sub infix:<∖>(\|$p) is equiv(&infix:<^>) {
return ∅ unless $p;
if $p[0] ~~ Baggy {
my @bags = $p.map(*.Bag);
my $base = @bags.shift;
Bag.new-from-pairs($base.keys.map({ ; $_ => $base{$_} - [+] @bags>>.{$_} }));
} else {
my @sets = $p.map(*.Set);
my $base = @sets.shift;
Set.new: $base.keys.grep(* ∉ @sets.any );
}
}
only sub infix:<(-)>($a, $b) is equiv(&infix:<^>) { $a ∖ $b }
proto sub infix:<⊖>($, $ --> Set) is equiv(&infix:<^>) {*}
multi sub infix:<⊖>(Any $a, Any $b --> Set) { $a.Set ⊖ $b.Set }
multi sub infix:<⊖>(Set $a, Set $b --> Set) { ($a (-) $b) ∪ ($b (-) $a) }
only sub infix:<(^)>($a, $b --> Set) is equiv(&infix:<^>) { $a ⊖ $b }
# TODO: polymorphic eqv
# multi sub infix:<eqv>(Any $a, Any $b --> Bool) { $a.Set eqv $b.Set }
# multi sub infix:<eqv>(Set $a, Set $b --> Bool) { $a == $b and so $a.keys.all ∈ $b }
multi sub infix:<⊆>(Any $a, Any $b --> Bool) { $a.Set ⊆ $b.Set }
multi sub infix:<⊆>(Set $a, Set $b --> Bool) { $a <= $b and so $a.keys.all ∈ $b }
only sub infix:['(<=)']($a, $b --> Bool) is equiv(&infix:<==>) { $a ⊆ $b }
only sub infix:<⊈>($a, $b --> Bool) is equiv(&infix:<==>) { $a !⊆ $b }
proto sub infix:<⊂>($, $ --> Bool) is equiv(&infix:<==>) {*}
multi sub infix:<⊂>(Any $a, Any $b --> Bool) { $a.Set ⊂ $b.Set }
multi sub infix:<⊂>(Set $a, Set $b --> Bool) { $a < $b and so $a.keys.all ∈ $b }
only sub infix:['(<)']($a, $b --> Bool) is equiv(&infix:<==>) { $a ⊂ $b }
only sub infix:<⊄>($a, $b --> Bool) is equiv(&infix:<==>) { $a !⊂ $b }
proto sub infix:<⊇>($, $ --> Bool) is equiv(&infix:<==>) {*}
multi sub infix:<⊇>(Any $a, Any $b --> Bool) { $a.Set ⊇ $b.Set }
multi sub infix:<⊇>(Set $a, Set $b --> Bool) { $a >= $b and so $b.keys.all ∈ $a }
only sub infix:['(>=)']($a, $b --> Bool) is equiv(&infix:<==>) { $a ⊇ $b }
only sub infix:<⊉>($a, $b --> Bool) is equiv(&infix:<==>) { $a !⊇ $b }
proto sub infix:<⊃>($, $ --> Bool) is equiv(&infix:<==>) {*}
multi sub infix:<⊃>(Any $a, Any $b --> Bool) { $a.Set ⊃ $b.Set }
multi sub infix:<⊃>(Set $a, Set $b --> Bool) { $a > $b and so $b.keys.all ∈ $a }
only sub infix:['(>)']($a, $b --> Bool) is equiv(&infix:<==>) { $a ⊃ $b }
only sub infix:<⊅>($a, $b --> Bool) is equiv(&infix:<==>) { $a !⊃ $b }
class SetHash does Associative {
has Bool %!elems;
method default { False }
method keys { %!elems.keys }
method values { %!elems.values }
method elems returns Int { %!elems.elems }
method exists($a) returns Bool { %!elems.exists($a) && %!elems{$a} }
method Bool { %!elems.Bool }
method Numeric { %!elems.Numeric }
method hash { %!elems.hash }
method Set { set self.keys }
method SetHash { self }
method Bag { bag self.keys }
method BagHash { BagHash.new(self.keys) }
method at_key($k) {
Proxy.new(FETCH => { %!elems{$k}:exists ?? True !! False },
STORE => -> $, $value { if $value { %!elems{$k} = True } else { %!elems{$k}:delete }});
}
method exists_key($k) { self.exists($k) }
method delete_key($k) { %!elems{$k}:delete }
# Constructor
method new(*@args --> SetHash) {
my %e;
for @args {
%e{$_} = True;
}
self.bless(:elems(%e));
}
submethod BUILD (%!elems) { }
method ACCEPTS($other) { defined(self) ?? $other ⊆ self && self ⊆ $other !! $other.^does(self) }
method Str() { self.defined ?? %!elems.keys().join(" ") !! nextsame }
method gist() { self.defined ?? "sethash({ %!elems.keys».gist.join(', ') })" !! "(SetHash)" }
method perl() { self.defined ?? 'SetHash.new(' ~ join(', ', map { .perl }, %!elems.keys) ~ ')' !! "SetHash" }
method iterator() { %!elems.keys.iterator }
method list() { %!elems.keys }
method pick($count = 1) { %!elems.keys.pick($count) }
method roll($count = 1) { %!elems.keys.roll($count) }
}
class Bag does Associative does Baggy {
has Int %!elems; # should be UInt
method default { 0 }
method keys { %!elems.keys }
method values { %!elems.values }
method elems { %!elems.elems }
method total { [+] self.values }
method exists($a) returns Bool { %!elems.exists($a) }
method Bool { %!elems.Bool }
method Numeric { self.total }
method hash { %!elems.hash }
method Set { set self.keys }
method SetHash { SetHash.new(self.keys) }
method Bag { self }
method BagHash { BagHash.new-from-pairs(self.hash) }
method at_key($k) { +(%!elems{$k} // 0) }
method exists_key($k) { self.exists($k) }
# Constructor
method new(*@args --> Bag) {
my %e;
for @args {
%e{$_}++;
}
self.bless(:elems(%e));
}
method new-from-pairs(*@pairs --> Bag) {
my %e;
for @pairs {
when Pair { %e{.key} = .value + (%e{.key} // 0); }
%e{$_}++;
}
for %e -> $p {
die "Negative values are not allowed in Bags" if $p.value < 0;
%e{$p.key}:delete if $p.value == 0;
}
self.bless(:elems(%e));
}
submethod BUILD (%!elems) { }
method ACCEPTS($other) { defined(self) ?? $other ≼ self && self ≼ $other !! $other.^does(self) }
method Str() {
self.defined ?? %!elems.pairs.map({ $_.value == 1 ?? $_.key.gist !! "{$_.key.gist}({$_.value})" }).flat.join(" ")
!! nextsame
}
method gist() { self.defined ?? "bag({ self.pairs>>.gist.join(', ') })" !! "(Bag)" }
method perl() { self.defined ?? '(' ~ %!elems.perl ~ ').Bag' !! "Bag" }
method iterator() { %!elems.pairs.iterator }
method list() { %!elems.keys }
method pairs() { %!elems.pairs }
method pick($count = 1) { my $kb = self.BagHash; $kb.pick($count); }
method roll($count = 1) { my $kb = self.BagHash; $kb.roll($count); }
}
sub bag(*@a) {
Bag.new(|@a);
}
only sub infix:<⊍>(\|$p) is equiv(&infix:<|>) {
my $set = Set.new: $p.map(*.Set.keys);
my @bags = $p.map(*.Bag);
Bag.new-from-pairs($set.map({ ; $_ => [*] @bags>>.{$_} }));
}
only sub infix:<(.)>(\|$p) is equiv(&infix:<&>) { infix:<⊍>(|$p) }
only sub infix:<⊎>(\|$p) is equiv(&infix:<|>) {
my $set = Set.new: $p.map(*.Set.keys);
my @bags = $p.map(*.Bag);
Bag.new-from-pairs($set.map({ ; $_ => [+] @bags>>.{$_} }));
}
only sub infix:<(+)>(\|$p) is equiv(&infix:<&>) { infix:<⊎>(|$p) }
multi sub infix:<≼>(Baggy $a, Baggy $b --> Bool) { so all $a.keys.map({ $a{$_} <= $b{$_} }) }
multi sub infix:<≼>(Any $a, Any $b --> Bool) { $a.Bag ≼ $b.Bag }
proto sub infix:<≽>($, $ --> Bool) is equiv(&infix:<==>) {*}
multi sub infix:<≽>(Baggy $a, Baggy $b --> Bool) { so all $b.keys.map({ $b{$_} <= $a{$_} }) }
multi sub infix:<≽>(Any $a, Any $b --> Bool) { $a.Bag ≽ $b.Bag }
class BagHash does Associative does Baggy {
has Int %!elems; # should be UInt
method default { 0 }
method keys { %!elems.keys }
method values { %!elems.values }
method elems { %!elems.elems }
method total { [+] self.values }
method exists($a) returns Bool { %!elems.exists($a) }
method Bool { %!elems.Bool }
method Numeric { self.total }
method hash { %!elems.hash }
method Set { set self.keys }
method SetHash { SetHash.new(self.keys) }
method Bag { Bag.new-from-pairs(self.hash) }
method BagHash { self }
method at_key($k) {
Proxy.new(FETCH => { %!elems{$k}:exists ?? %!elems{$k} !! 0 },
STORE => -> $, $value { if $value > 0 { %!elems{$k} = $value } else { %!elems{$k}:delete }});
}
method exists_key($k) { self.exists($k) }
method delete_key($k) { %!elems{$k}:delete }
# Constructor
method new(*@args --> BagHash) {
my %e;
for @args {
%e{$_}++;
}
self.bless(:elems(%e));
}
method new-from-pairs(*@pairs --> BagHash) {
my %e;
for @pairs {
when Pair { %e{.key} = .value + (%e{.key} // 0); }
%e{$_}++;
}
for %e -> $p {
die "Negative values are not allowed in BagHashs" if $p.value < 0;
%e{$p.key}:delete if $p.value == 0;
}
self.bless(:elems(%e));
}
submethod BUILD (%!elems) { }
method ACCEPTS($other) { defined(self) ?? $other ≼ self && self ≼ $other !! $other.^does(self) }
method Str() {
self.defined ?? %!elems.pairs.map({ $_.value == 1 ?? $_.key.gist !! "{$_.key.gist}({$_.value})" }).flat.join(" ")
!! nextsame
}
method gist() { self.defined ?? "baghash({ self.pairs>>.gist.join(', ') })" !! "(BagHash)" }
method perl() { self.defined ?? %!elems.perl ~ '.BagHash' !! "BagHash" }
method iterator() { %!elems.pairs.iterator }
method list() { %!elems.keys }
method pairs() { %!elems.pairs }
method pick($count = 1) {
return self.roll if $count ~~ Num && $count == 1;
my $temp-bag = BagHash.new-from-pairs(self.hash);
my $lc = $count ~~ Whatever ?? Inf !! $count;
gather while $temp-bag && $lc-- {
my $choice = $temp-bag.roll;
take $choice;
$temp-bag{$choice}--;
}
}
# Borrowed from Rakudo, doesn't seem to work properly in Niecza
# method pickpairs ($count = 1) {
# (%!elems{ %!elems.keys.pick($count) }).list;
# }
method roll($count = 1) {
my @inverse-mapping;
my $a = 0;
for %!elems.pairs -> $pair {
$a += $pair.value;
@inverse-mapping.push((+$a) => $pair.key);
}
sub choose {
my $choice = $a.rand;
my $i = 0;
for @inverse-mapping -> $im {
if $choice ~~ $i ..^ +$im.key {
return $im.value;
}
$i = $im.key;
}
}
return choose() xx * if $count ~~ Whatever;
return choose() if $count == 1;
return choose() xx $count;
}
}
my class Junction is Mu {
has $!kind_;
has $!eigenstates_;
method !create($kind, $eigenstates) { Q:CgOp {
(letn ob (obj_newblank (obj_llhow (@ {self})))
(setslot Junction $!kind_ (l ob) (@ {$kind}))
(setslot Junction $!eigenstates_ (l ob) (@ {$eigenstates}))
(l ob))
} }
method !kind() { Q:CgOp { (getslot Junction $!kind_ obj (@ {self})) } }
method !eigenstates() { Q:CgOp { (getslot Junction $!eigenstates_ obj (@ {self})) } }
my @kinds = <all none one any>;
method perl() {
defined(self) ?? (@kinds[self!kind] ~ (anon @ := self!eigenstates).perl)
!! "Junction"
}
method immutable() { self // return True; self!eigenstates.immutable }
method Str() { defined(self) ?? self.perl !! "Junction()" }
method from-parcel(Int $kind, \pcl) {
self!create($kind, pcl)
}
method ACCEPTS(Mu \other) {
defined(self) ??
?(self.FALLBACK("ACCEPTS", other)) !!
other.^isa(self)
}
}
# }}}
# List utilities {{{
my class GatherIterator is IterCursor {
has $.frame;
has $!reify;
method reify() {
my $*nextframe;
$!reify // ($!reify = (
Q:CgOp {
(letn getv (cotake (cast frame (@ {$!frame})))
(setslot (obj_llhow (@ {self})) $!frame (@ {self}) {Any})
(box Parcel (ternary (== (@ {EMPTY}) (@ (l getv)))
(fvarlist_new)
(fvarlist_new
(l getv)
{GatherIterator.new(frame => $*nextframe)}))))
}));
}
}
sub _gather($fr) {
&infix:<,>(GatherIterator.new(frame => $fr)).list
}
sub reverse(*@array) {
my @acc;
push @acc, pop(@array) while @array;
@acc;
}
sub classify($mapper, *@values) { @values.classify($mapper) }
sub categorize($mapper, *@values) { @values.categorize($mapper) }
sub min(*@args, :&by = &infix:<cmp>) { @args.min(&by) }
sub max(*@args, :&by = &infix:<cmp>) { @args.max(&by) }
sub minmax(*@args, :&by = &infix:<cmp>) { @args.minmax(&by) }
sub end($a) { $a.end }
sub join($tween = "", *@stuff) { @stuff.join($tween) }
sub invert(%h) { %h.invert }
sub keys($h) { $h.keys }
sub values($h) { $h.values }
sub kv($p) { $p.kv }
sub pairs($p) { $p.pairs }
sub elems($p) { $p.elems }
sub sort(*@values) {
if @values && @values[0] ~~ Callable {
my $cmp = @values.shift;
@values.sort($cmp);
} else {
@values.sort;
}
}
sub first(Mu $test, *@bits) { @bits.first($test) }
sub _hash_constructor(\parcel) { my $r := (anon %hash = parcel); $r }
sub _make_capture(|c) { c }
# strange API for this, no?
my class Proxy {
method new(:$FETCH, :$STORE, :$BIND) {
Q:CgOp { (var_new_tied (@ {$BIND}) (@ {$FETCH}) (@ {$STORE})) }
}
}
# a few notes: Not all of these are protos yet, so the failure candidates
# for x, etc are left out. No candidates for operators that don't exist yet.
# No candidates are needed for chain operators or list operators, reduce can
# handle those fine.
multi infix:<**>() { 1 }
multi infix:<*>() { 1 }
multi infix:</>() { die "No zero-arg meaning for infix:</>" }
multi infix:<%>() { die "No zero-arg meaning for infix:<%>" }
#multi infix:<x>() { die "No zero-arg meaning for infix:<x>" }
#multi infix:<xx>() { die "No zero-arg meaning for infix:<xx>" }
multi infix:<+&>() { -1 }
multi infix:«+<»() { die "No zero-arg meaning for infix:<< +< >>" }
multi infix:«+>»() { die "No zero-arg meaning for infix:<< +> >>" }
#multi infix:«~&»() { die "No zero-arg meaning for infix:<~&>" }
#multi infix:«~<»() { die "No zero-arg meaning for infix:<< ~< >>" }
#multi infix:«~>»() { die "No zero-arg meaning for infix:<< ~> >>" }
multi infix:<+>() { 0 }
multi infix:<->() { 0 }
multi infix:<+|>() { 0 }
multi infix:<+^>() { 0 }
#multi infix:<~|>() { '' }
#multi infix:<~^>() { '' }
#multi infix:<&&>() { True }
#multi infix:<||>() { False }
#multi infix:<^^>() { False }
#multi infix:<//>() { Any }
sub reduceop($triangle, $list, $right, $chain, $func, *@items) {
if $triangle {
if $chain {
gather {
my $ok = True;
if @items {
take True;
my Mu $last = shift @items;
while @items {
my Mu $next = shift @items;
my Mu $val ::= ($ok &&= $func($last, $next));
take $val;
$last = $next;
}
}
}
}
elsif $list {
my @pool;
gather {
while @items {
push @pool, shift @items;
take reduceop(False, $list, $right, $chain, $func, @pool);
}
}
}
elsif $right {
gather {
while @items >= 2 {
my Mu $right ::= pop @items;
take $right;
my Mu $left = pop @items;
push @items, $func($left,$right);
}
if @items {
my Mu $last ::= shift @items;
take $last;
}
}
}
else { # left assoc
gather {
if @items {
my Mu $cumu ::= shift @items;
take $cumu;
while @items {
my Mu $new ::= ($cumu ::= $func($cumu, shift @items));
take $new;
}
}
}
}
}
else {
if $list {
$func(|@items);
}
elsif $chain {
my $ok = True;
while @items >= 2 {
$ok &&= $func(@items[0], @items[1]);
shift @items;
}
$ok;
}
elsif $right {
while @items >= 2 {
my Mu $r = pop @items;
my Mu $l = pop @items;
push @items, $func($l,$r);
}
@items ?? @items[0] !! $func();
}
else { # left
while @items >= 2 {
my Mu $l = shift @items;
my Mu $r = shift @items;
unshift @items, $func($l,$r);
}
@items ?? @items[0] !! $func();
}
}
}
my class NieczaLSM {
has Cool $.source;
has @!substitutions;
has Int $!index = 0;
has Int $!next_match;
has $!next_substitution;
has $!substitution_length;
has Str $.unsubstituted_text;
has Str $.substituted_text;
method add_substitution($key, $value) {
push @!substitutions, $key => $value;
}
method compare_substitution($substitution, Int $pos, Int $length) {
if $!next_match > $pos
|| $!next_match == $pos && $!substitution_length < $length {
$!next_match = $pos;
$!substitution_length = $length;
$!next_substitution = $substitution;
}
}
multi method triage_substitution($substitution where { $^s.key ~~ Regex }) {
my $key = $substitution.key;
return unless $.source.substr($!index) ~~ $key;
self.compare_substitution($substitution, $!index + $/.from.Int, $/.to.Int - $/.from.Int);
}
multi method triage_substitution($substitution where { $^s.key ~~ Cool }) {
return unless defined index($.source, $substitution.key, $!index);
self.compare_substitution($substitution,
index($.source, $substitution.key, $!index),
$substitution.key.chars);
}
multi method triage_substitution($substitution) {
die "Don't know how to handle a {$substitution.WHAT} as a substitution key";
}
multi method increment_index(Regex $s) {
$.source.substr($!index) ~~ $s;
$!index = $!next_match + $/.chars.Int;
}
multi method increment_index(Cool $s) {
$!index = $!next_match + $s.chars;
}
method next_substitution() {
$!next_match = $.source.chars;
for @!substitutions {
self.triage_substitution($_);
}
$!unsubstituted_text
= $.source.substr($!index, $!next_match - $!index);
if defined $!next_substitution {
my $result = $!next_substitution.value;
$!substituted_text
= $result ~~ Callable ?? ~$result() !! $result;
self.increment_index($!next_substitution.key);
}
return $!next_match < $.source.chars;
}
}
sub Niecza-trans($str, *@changes) {
my sub expand($s) {
return $s.list if $s ~~ Positional;
gather for $s.comb(/ (\w) '..' (\w) | . /, :match) {
if .[0] {
take $_ for ~.[0] .. ~.[1];
} else {
take ~$_;
}
}
}
my $lsm = NieczaLSM.new(:source($str));
for (@changes) -> $p {
die "$p.perl() is not a Pair" unless $p ~~ Pair;
if $p.key ~~ Regex {
$lsm.add_substitution($p.key, $p.value);
}
elsif $p.value ~~ Callable {
my @from = expand $p.key;
for @from -> $f {
$lsm.add_substitution($f, $p.value);
}
}
else {
my @from = expand $p.key;
my @to = expand $p.value;
if @to {
@to = @to xx ceiling(@from / @to);
} else {
@to = '' xx @from;
}
for @from Z @to -> $f, $t {
$lsm.add_substitution($f, $t);
}
}
}
my @r;
while $lsm.next_substitution {
push @r, $lsm.unsubstituted_text ~ $lsm.substituted_text;
}
push @r, $lsm.unsubstituted_text;
return @r.join;
}
# }}}
# Regular expression support {{{
my grammar Cursor is Any does Associative does Positional {
method at_key($k) { self.{$k} }
method at_pos($k) { self.[$k] }
method suppose($rx) {
my $*IN_SUPPOSE = True;
my $*FATALS = 0;
my @*WORRIES;
my %*WORRIES;
my $*HIGHWATER = -1;
my $*HIGHEXPECT = {};
try {
my $ret = head($rx(self));
if ($ret) { return $ret }
};
return ();
}
method O (*%hash) {
Q:CgOp { (cursor_O (cast cursor (@ {self}))
(unbox varhash (@ {%hash}))) }
}
method ast () { Q:CgOp { (cursor_ast (cast cursor (@ {self}))) } }
method list () { @( self.Capture ) }
method flat () { @( self.Capture ) }
method iterator () { self.flat.iterator }
method hash () { %( self.Capture ) }
method Capture () { Q:CgOp {
(letn cap (obj_newblank (obj_llhow (@ {Capture})))
(cursor_unpackcaps (cast cursor (@ {self})) (l cap))
(l cap))
} }
method cursor_start($str, $act?) { Q:CgOp { (cursor_start
(@ {self}) (obj_getstr {$str}) (@ {$act})) } }
method pos() { Q:CgOp { (box Num (cast num (cursor_pos
(cast cursor (@ {self}))))) } }
method to() { Q:CgOp { (box Num (cast num (cursor_pos
(cast cursor (@ {self}))))) } }
method cursor($np) { Q:CgOp { (cursor_butpos
(cast cursor (@ {self})) (cast int (obj_getnum {$np}))) } }
method orig() { Q:CgOp {
(box Str (cursor_backing (cast cursor (@ {self})))) } }
method ws() { Q:CgOp { (cursor_dows (cast cursor (@ {self}))) } }
method CURSOR() { self }
method FAILGOAL ($stop, $name, $startpos) { #OK not used
my $s = "'$stop'";
$s = '"\'"' if $s eq "'''";
die("Unable to parse $name\nCouldn't find final $s; gave up");
}
# definitions from UTS18
token alpha { <:Alphabetic + [_]> } # XXX: STD expects to include _
token lower { <:Lowercase> }
token upper { <:Uppercase> }
token punct { <:Punctuation> }
token digit { \d }
token xdigit { <:Nd + :Hex_Digit> }
token alnum { <:Alphabetic + :Nd + [_]> }
token space { \s }
token blank { \h }
token cntrl { <:Control> }
token graph { <:ANY - :Whitespace - :Control - :Surrogate - :Unassigned> }
token print { <+graph + blank - cntrl> }
token word { \w }
token ident { <.alpha> \w* }
}
my class Match is Cool does Associative does Positional {
method at_key($k) { self.{$k} }
method at_pos($k) { self.[$k] }
method ACCEPTS($) { self // nextsame }
method list () { @( self.Capture ) }
method hash () { %( self.Capture ) }
method flat () { @( self.Capture ) }
method iterator () { self.flat.iterator }
method Numeric() { self // nextsame; +(~self) }
# yeah these could all be more efficient.
method kv() { (@(self).kv, %(self).kv).flat }
method keys() { (@(self).keys, %(self).keys).flat }
method values() { (@(self), %(self).values).flat }
method Capture () { Q:CgOp {
(letn cap (obj_newblank (obj_llhow (@ {Capture})))
(cursor_unpackcaps (cast cursor (@ {self})) (l cap))
(l cap))
} }
method new($) { die "Match.new NYI" }
method from() { Q:CgOp { (box Num (cast num (cursor_from
(cast cursor (@ {self}))))) } }
method to() { Q:CgOp { (box Num (cast num (cursor_pos
(cast cursor (@ {self}))))) } }
method pos() { self.to }
method orig() { Q:CgOp {
(box Str (cursor_backing (cast cursor (@ {self})))) } }
method ast () { Q:CgOp { (cursor_ast (cast cursor (@ {self}))) } }
method chars() { defined(self) ?? $.to - $.from !! 0 }
method perl() {
self // nextsame;
my @pos = @(self);
@pos = () if @pos == 1 && @pos[0] === self;
"#<match from({ self.from }) to({ self.to }) text({ self }) pos({ @pos.perl }) named({ %(self).perl })>"
}
multi method gist ($d = 0) {
return "(Match)" unless self;
my $s = ' ' x ($d + 1);
my $r = ("=> " if $d) ~ "\x[FF62]{self}\x[FF63]\n";
for @.caps {
$r ~= $s ~ (.key // '?') ~ ' ' ~ .value.gist($d + 1)
}
$r;
}
method CURSOR() { Q:CgOp { (cursor_unmatch (cast cursor (@ {self}))) } }
method cursor() { Q:CgOp { (cursor_unmatch (cast cursor (@ {self}))) } }
method reduced() { Q:CgOp { (box Str (cursor_reduced (cast cursor (@ {self})))) } }
method synthetic(:$cursor!, :$method = "", :$captures, :$from!, :$to!) {
my $*match;
Q:CgOp {
(prog
(cursor_synthetic
(cast cursor (@ {$cursor})) (obj_getstr {$method})
(cast int (obj_getnum {$from}))
(cast int (obj_getnum {$to}))
{@$captures})
{$*match})
};
}
method caps() {
my @caps = Q:CgOp { (cursor_allcaps {self}) }.sort({ .value.from });
my $lpos = self.from;
my $lnam = "beginning of match";
for @caps {
if .value.from < $lpos {
warn "Capture {.key} starts at {.value.from} overlaps $lnam at $lpos";
}
$lpos = .value.to;
$lnam = .key;
}
if self.to < $lpos {
warn "End of match at {self.to} overlaps $lnam at $lpos";
}
@caps
}
method chunks() {
my $lpos = self.from;
my @chunks;
for self.caps {
if .value.from > $lpos {
push @chunks, '~' => Match.synthetic(:cursor(self), :captures[],
:from($lpos), :to(.value.from));
}
push @chunks, $_;
$lpos = .value.to;
}
if self.to > $lpos {
push @chunks, '~' => Match.synthetic(:cursor(self), :captures[],
:from($lpos), :to(self.to));
}
@chunks
}
method postmatch() { substr(self.orig, self.to) }
method prematch() { substr(self.orig, 0, self.from) }
}
my class Regex is Method {
method Bool() {
return False unless defined self;
my $fr = caller;
# Hack - skip ExitRunloop frame
$fr = $fr.caller unless $fr.line;
Q:CgOp {
(letn res {self.ACCEPTS($fr.hints('$_'))}
(set_status (s $/) {$/})
(asbool (l res)))
};
}
method ACCEPTS($st) {
self // nextsame;
Q:CgOp {
(letn ix (i 0)
str (obj_getstr {$st})
max (str_length (l str))
incr (cursor_start (@ {Cursor}) (l str) (@ {Any}))
csr (null cursor)
iter (null vvarlist)
(whileloop 0 0 (<= (l ix) (l max)) (prog
(l csr (cursor_butpos (l incr) (l ix)))
(l ix (+ (l ix) (i 1)))
(l iter (vvarlist_new_singleton
(subcall (@ {self}) (l csr))))
(ternary (iter_hasflat (l iter))
(letn val (vvarlist_shift (l iter))
(set_status (s $/) (l val))
(return (newrwlistvar (@ (l val))) (l val)))
(prog))))
(set_status (s $/) {Nil})
{Nil})
};
}
}
my class Grammar is Cursor {
method parse($text, :$rule = "TOP", :$actions) {
my $match = (head grep { $_.to == chars $text },
self.cursor_start($text, $actions)."$rule"()) // Nil;
Q:CgOp { (rnull (set_status (s '$/') {$match})) };
$match;
}
}
# }}}
# Other operators {{{
# TODO: these should be macros
sub WHAT(\x) { x.WHAT }
sub HOW(\x) { x.HOW }
constant Inf = 1 / 0;
my class NumericRangeIter is IterCursor {
has $.current;
has $.limit;
has $.exclusive;
# reify implemented in lower-level code
}
my class RangeIter is IterCursor {
has $.current;
has $.limit;
has $.exclusive;
method reify() {
my $c = $!current;
my $cmp = $c cmp $!limit;
($cmp < 0) ?? ($c, RangeIter.new(current => $c.succ,
limit => $!limit, exclusive => $!exclusive)) !!
($cmp > 0 || $!exclusive) ?? () !!
($c,);
}
}
my class Range is Cool does Positional {
has $.min;
has $.max;
has $.excludes_min = False;
has $.excludes_max = False;
method new($min is copy, $max is copy, :$excludes_min = False, :$excludes_max = False) {
$max = Inf if $max.^isa(Whatever);
if $min ~~ Numeric && $max !~~ Numeric {
$max = +$max;
}
$min = -Inf if $min.^isa(Whatever);
unitem(self.bless(:$min, :$max, :$excludes_min, :$excludes_max));
}
method immutable() { self // return True; $!min.immutable && $!max.immutable }
method list() { self.iterator.list }
method flat() { self.iterator.flat }
method at_pos(\key) { @(self).at_pos(key) }
method bounds() { $.min, $.max }
method from() { $.min }
method to() { $.max }
method minmax($cmp = &infix:<cmp>) { self.iterator.list.minmax($cmp) }
method iterator() {
my \mn = $!min;
my \mx = $!max;
&infix:<,>((((mn ~~ Numeric) && (mx ~~ Numeric)) ?? NumericRangeIter !! RangeIter)\
.new(:current($!excludes_min ?? mn.succ !! mn),
:limit(mx), :exclusive($!excludes_max))).iterator
}
method Str() { self.list.Str }
method Numeric() { +self.list }
method perl() {
( $.min.perl,
('^' if $.excludes_min),
'..',
('^' if $.excludes_max),
$.max.perl
).join('');
}
method ACCEPTS($topic) {
!defined(self) ?? ($topic.^isa(Range)) !!
($topic.^isa(Range) ??
(($.min == $topic.min)
&& ($.max == $topic.max)
&& ($.excludes_min == $topic.excludes_min)
&& ($.excludes_max == $topic.excludes_min)) !!
(self!min_test($topic) && self!max_test($topic)))
}
method niecza_quantifier_min() {
($!min == -Inf ?? 0 !! $!min + $!excludes_min)
}
method niecza_quantifier_max() {
($!max == Inf ?? 2_147_483_647 !! $!max - $!excludes_max)
}
method !max_test($topic) {
$topic before $.max || (!$.excludes_max && !($topic after $.max));
}
method !min_test($topic) {
$.min before $topic || (!$.excludes_min && !($.min after $topic));
}
method fmt($format = '%s', $separator = ' ') {
self.list.fmt($format, $separator);
}
method roll($count = 1) {
return self.list.roll($count) unless $!min.^isa(Int) && $!max.^isa(Int);
my $least = $!excludes_min ?? $!min + 1 !! $!min;
my $elems = 1 + ($!excludes_max ?? $!max - 1 !! $!max) - $least;
sub choose {
$elems ?? ($least + Q:CgOp { (bigrand {$elems}) }) !! Any;
}
return choose() xx * if $count ~~ Whatever;
return choose() if $count == 1;
return choose() xx $count;
}
method pick($count = 1) {
return self.list.pick($count) unless $!min.^isa(Int) && $!max.^isa(Int);
return self.list.pick(*) if $count ~~ Whatever;
return self.roll if $count == 1;
return self.list.pick($count) unless $!max - $!min > 3 * $count;
my %seen;
my $i = 0;
gather while $i < $count {
my $x = self.roll;
unless %seen{$x} {
%seen{$x} = 1;
$i++;
take $x;
}
}
}
}
sub infix:<..> is equiv<leg> ($a, $b) is pure { Range.new($a, $b) }
sub infix:<..^> is equiv<leg> ($a, $b) is pure { Range.new($a, $b, :excludes_max) }
sub infix:<^..> is equiv<leg> ($a, $b) is pure { Range.new($a, $b, :excludes_min) }
sub infix:<^..^> is equiv<leg> ($a, $b) is pure { Range.new($a, $b, :excludes_min, :excludes_max) }
sub _hyper_type($val) {
#FIXME rewrite using roles
given $val {
when Hash { return 1 }
when List { return 2 }
when Parcel { return 2 }
when Range { return 2 }
default { return 0 }
}
}
sub hyperunary(&fun, \obj) {
given _hyper_type(obj) {
when 1 {
my %out;
for obj.kv -> $k, \v {
%out{$k} = hyperunary(&fun, v);
}
return %out;
}
when 2 {
my @out;
push @out, $( hyperunary(&fun, $_) ) for @(obj);
return @out;
}
when 3 {
my @out;
push @out, $( hyperunary(&fun, $_) ) for @(obj);
return obj.new(@out);
}
when 0 {
return fun(obj);
}
}
}
sub _hyper_hash($dwiml, $dwimr, $fun, $left, $right) {
my %keys;
for $left.keys {
%keys{$_} = True if !$dwiml || ($right{$_}:exists);
}
for $right.keys {
%keys{$_} = True if !$dwimr || ($left{$_}:exists);
}
for %keys.keys {
%keys{$_} = hyper($dwiml, $dwimr, $fun, $left{$_}, $right{$_});
}
%keys
}
sub _hyper_posi($dwiml, $dwimr, $fun, $left, $right) {
my $lex = $left[*-1] ~~ Whatever;
my $rex = $right[*-1] ~~ Whatever;
my @out;
my $ix = 0;
loop {
my $lend; my $lv; my $rend; my $rv;
if $ix >= ($lex ?? $left - 1 !! $left) {
$lend = True;
$lv := $left[$lex ?? $left - 2 !! $left ?? $ix % $left !! 0];
} else {
$lv := $left[$ix];
}
if $ix >= ($rex ?? $right - 1 !! $right) {
$rend = True;
$rv := $right[$rex ?? $right - 2 !! $right ?? $ix % $right !! 0];
} else {
$rv := $right[$ix];
}
last if $lend && $rend;
die "Ran off end of non-dwimmy left" if $lend && !$dwiml && !$dwimr;
die "Ran off end of non-dwimmy right" if $rend && !$dwiml && !$dwimr;
last if $lend && !$dwiml;
last if $rend && !$dwimr;
push @out, $( hyper($dwiml, $dwimr, $fun, $lv, $rv) );
$ix++;
}
@out;
}
sub hyper($dwiml, $dwimr, $fun, \left, \right) {
constant @htnames = 'scalar', 'Associative', 'Positional', #OK
'non-Positional Iterable';
my $h1 = _hyper_type(left);
my $h2 = _hyper_type(right);
if $h1 && $h2 && $h1 != $h2 {
die "Cannot mix @htnames[$h1] and @htnames[$h2] in hyperop";
}
if $h2 == 0 || $h1 == 0 {
if $h1 == 0 && $h2 == 0 { return $fun(left, right) }
if $h2 {
if $dwiml {
return hyperunary(sub (\x) { $fun(left,x) }, right);
}
} else {
if $dwimr {
return hyperunary(sub (\x) { $fun(x,right) }, left);
}
}
die "Non-dwimmy scalar used with complex item";
}
given $h1 {
when 1 { return _hyper_hash($dwiml, $dwimr, $fun, left, right) }
when 2 { return _hyper_posi($dwiml, $dwimr, $fun, @(left), @(right)) }
when 3 { die "Cannot hyper two unordered collections" }
}
}
# tweaked from Rakudo
our sub Niecza::generate-series(@lhs, $rhs, :$exclude-limit) {
my sub get-next-closure (@lhs, $limit? ) {
die "Need something on the LHS" unless @lhs.elems;
die "Need more items on the LHS" if @lhs[*-1] ~~ Code && @lhs[*-1].count != Inf && @lhs.elems - 1 < @lhs[*-1].arity;
#BEWARE: Here be ugliness
if @lhs[* - 1] ~~ Code { # case: (a,b,c,{code}) ... *
return @lhs[*-1];
}
return { .succ } if @lhs.elems == 1 && $limit ~~ Code;
return { $_ } if @lhs.elems > 1 && @lhs[*-1] cmp @lhs[*-2] == 0 ; # case: (a , a) ... *
if @lhs[*-1] ~~ Str || $limit ~~ Str {
if @lhs[*-1].codes == 1 && $limit.defined && $limit.codes == 1 {
return { .ord.succ.chr } if @lhs[*-1] lt $limit;# case (... , non-number) ... limit
return { .ord.pred.chr } if @lhs[*-1] gt $limit;# case (... , non-number) ... limit
}
return { .succ } if $limit.defined && @lhs[*-1] lt $limit;# case (... , non-number) ... limit
return { .pred } if $limit.defined && @lhs[*-1] gt $limit;# case (... , non-number) ... limit
return { .pred } if @lhs.elems > 1 && @lhs[*-2] gt @lhs[*-1];# case (non-number , another-smaller-non-number) ... *
return { .succ } ;# case (non-number , another-non-number) ... *
}
return { .pred } if @lhs.elems == 1 && $limit.defined && $limit before @lhs[* - 1]; # case: (a) ... b where b before a
return { .succ } if @lhs.elems == 1 ; # case: (a) ... *
my $diff = @lhs[*-1] - @lhs[*-2];
return { $_ + $diff } if @lhs.elems == 2 || @lhs[*-2] - @lhs[*-3] == $diff ; #Case Arithmetic series
if @lhs[*-2] / @lhs[*-3] == @lhs[*-1] / @lhs[*-2] { #Case geometric series
my $factor = @lhs[*-2] / @lhs[*-3];
if $factor ~~ Rat && $factor.denominator == 1 {
$factor = $factor.Int;
}
return { $_ * $factor } ;
}
die "Unable to figure out pattern of series";
}
my sub infinite-series (@lhs, $limit ) {
gather {
my $i = 0;
# Take all items from the LHS except for terminal Codes
# (ordered this way to avoid overeager evaluation)
while (@lhs[$i].defined && @lhs[$i] !~~ Code) || @lhs[$i+1].defined {
take @lhs[$i]; $i++;
}
my $next = get-next-closure(@lhs , $limit );
my $arity = $next.count;
my @args=@lhs[$i-($arity ~~ Inf ?? $i !! $arity) .. $i-1]; #We make sure there are $arity elems in args
loop { #Then we extrapolate using $next and the $args
my \current = $next.(|@args) // last;
take current ;
if $arity {
@args.push(current) ;
@args.shift while @args.elems > $arity
}
}
}
}
my $limit = ($rhs ~~ Whatever ?? Any !! $rhs);
return infinite-series(@lhs , $limit) if $rhs ~~ Whatever; #shortcut infinite series so we avoid the comparisions
my $series = infinite-series(@lhs , $limit);
gather {
if $limit ~~ Code && $limit.count > 1 {
my @limit-args;
while $series {
@limit-args.shift if @limit-args == $limit.count;
my $val = $series.shift;
@limit-args.push($val);
my $done = @limit-args >= $limit.arity && $limit(|@limit-args);
take $val unless $done && $exclude-limit;
last if $done;
}
}
else {
while $series {
my $val = $series.shift();
if $val ~~ $limit {
take $val unless $exclude-limit ;
last ;
};
take $val;
}
}
}
}
our sub Niecza::series-listop(Parcel $lists, $exclude-limit) {
if $lists.raw_elems <= 1 { return unitem($lists) }
my @l := ( $lists.raw_at($lists.raw_elems - 1), ).flat;
loop (my $i = $lists.raw_elems - 2; $i >= 0; $i = $i - 1) {
@l || die "Need something on the RHS";
my @mo := &Niecza::generate-series(($lists.raw_at($i),).flat, @l.shift,
:$exclude-limit);
@l := ( @mo, @l ).flat;
}
@l
}
sub undefine(Mu \x) { x = Any }
sub infix:<%%> is equiv<*> is iffy is pure ($x,$y) { $x % $y == 0 }
sub infix:<?&> is equiv<*> is iffy is pure ($a, $b) { ?($a && $b) }
sub infix:<?|> ($a, $b) is pure is iffy { ?($a || $b) }
sub infix:<?^> ($a, $b) is pure { ?( +$a +^ $b ) }
sub prefix:<?^> ($a) is pure { !$a }
sub prefix:<|> (\item) { item.Capture } # marking this pure breaks syntax
sub prefix:<^> ($limit) is pure { 0 ..^ +$limit }
sub prefix:<so> is equiv<not> is pure (\item) { ?item }
sub infix:<xx> is equiv<x> (\list, $ct) { map { list }, ($ct ~~ Whatever) ?? ^Inf !! ^$ct }
sub _doreplicate($func, $ct) { map { $func() }, ($ct ~~ Whatever) ?? ^Inf !! ^$ct }
sub prefix:<abs> ($x) is pure { Q:CgOp { (abs {$x}) } }
sub abs($x) is pure { Q:CgOp { (abs {$x}) } }
sub floor($x) is pure { Q:CgOp { (floor {$x}) } }
sub ceiling($x) is pure { -floor(-$x) }
sub conj($x) is pure { $x.conj }
sub round($x, $scale=1) is pure { floor($x / $scale + 0.5) * $scale }
sub truncate($x) is pure { $x.Int }
sub sign($x) is pure { $x < 0 ?? -1 !! $x > 0 ?? 1 !! 0 }
multi sub exp($x) { $x.exp }
multi sub exp($x, $base) { $base ** $x }
sub infix:« <=> » is equiv<leg> ($a, $b) is pure {
$a < $b ?? Order::Less !! $a > $b ?? Order::More !! Order::Same
}
# XXX polymorphic equality
sub infix:<cmp> is equiv<leg> (Mu $a, Mu $b) {
return $a <=> $b if $a ~~ Real && $b ~~ Real;
if $a ~~ Real {
return Order::Less if $a == -Inf;
return Order::More if $a == Inf;
}
if $b ~~ Real {
return Order::Less if $b == Inf;
return Order::More if $b == -Inf;
}
return ($a ~~ Real ?? "(Real)" !! $a.WHAT.gist) leg
($b ~~ Real ?? "(Real)" !! $b.WHAT.gist)
unless Niecza::ValueIdentity($a.WHAT, $b.WHAT);
return 0 if !$a.defined && !$b.defined;
return $a leg $b if $a ~~ Str;
return $a.key cmp $b.key || $a.value cmp $b.value if $a ~~ Pair;
if $a ~~ List {
for @$a Z @$b -> $i1, $i2 {
(my $r = $i1 cmp $i2) && return $r
}
return $a <=> $b;
}
if $a ~~ Hash {
my $keys = set $a.keys, $b.keys;
my @keys = $keys.keys.sort;
for @keys -> $k {
return Order::More unless $a{$k} :exists;
return Order::Less unless $b{$k} :exists;
(my $r = $a{$k} cmp $b{$k}) && return $r;
}
return Order::Same;
}
return $a <=> $b;
}
sub infix:<eqv> is equiv<==> (Any $a, Any $b) { ($a.WHAT.gist cmp $b.WHAT.gist) == 0 && ($a cmp $b) == 0 }
sub infix:<before> ($a, $b) is equiv<==> { ($a cmp $b) < 0 }
sub infix:<after> ($a, $b) is equiv<==> { ($a cmp $b) > 0 }
sub seqop($op, \x, \y) { $op(x,y) } # TODO: Special case with hyper
sub reverseop($op, \x, \y) { $op(y, x) }
sub infix:<div> is equiv<*> ($x,$y) is pure { Q:CgOp { (divop (i 4) {$x} {$y}) } }
sub infix:<mod> is equiv<*> ($x,$y) is pure { Q:CgOp { (divop (i 5) {$x} {$y}) } }
sub infix:<~&> ($x, $y) { die "Buffer bitops NYI"; } #OK
sub infix:<~|> ($x, $y) { die "Buffer bitops NYI"; } #OK
sub infix:<~^> ($x, $y) { die "Buffer bitops NYI"; } #OK
sub infix:«~<» ($x, $y) { die "Buffer bitops NYI"; } #OK
sub infix:«~>» ($x, $y) { die "Buffer bitops NYI"; } #OK
sub prefix:<~^> ($x) { die "Buffer bitops NYI"; } #OK
sub prefix:<||> (\|$args) { die "Slicels NYI" } #OK
sub postfix:<i> ($item) is pure is fiddly is uassoc<left> { $item ~~ Complex ?? $item * i !! Complex.new(0, $item) }
sub prefix:<sleep> ($x) { Q:CgOp { (sleep (obj_getnum {$x})) } }
sub infix:<...> is equiv<X> (\|$lists) { &Niecza::series-listop($lists, False) }
sub infix:<...^> is equiv<X> (\|$lists) { &Niecza::series-listop($lists, True) }
sub infix:« ==> »(\|$args) { die "Feed ops NYI" } #OK
sub infix:« ==>> »(\|$args) { die "Feed ops NYI" } #OK
sub infix:« <== »(\|$args) { die "Feed ops NYI" } #OK
sub infix:« <<== »(\|$args) { die "Feed ops NYI" } #OK
sub EVAL($str,:$lang="perl6") is return-pass {
if $lang eq "perl6" {
Q:CgOp { (simple_eval {$str}) }
} else {
Q:CgOp { (eval_perl5 {$str}) }
}
}
sub rungather($command_line) is unsafe { Q:CgOp { (box Str (command_qx (obj_getstr {$command_line}))) } }
# tiny stub for Dancer
my class DateTime {
has $!now;
method new($now) {
self := self.bless();
$!now = $now;
self;
}
method Str() { $!now }
}
# a rather strange grammar. All of its rules are tokens, and some of them
# will die().
grammar Niecza::NumSyntax {
# this is a high candidate to be rewritten in C#
sub from_base(Str $str, Int $base) {
my $acc = 0;
my $places = 0;
my $ch;
my $digit;
loop (my $ix = 0; $ix < chars($str); ++$ix) {
$ch = ord(substr($str,$ix,1));
$ch == 0x5F and next;
++$places;
0x30 <= $ch <= 0x39 and $digit = $ch - 0x30;
0x61 <= $ch <= 0x7A and $digit = $ch - 0x57;
0x41 <= $ch <= 0x5A and $digit = $ch - 0x37;
die "Digit <{substr($str,$ix,1)}> too large for radix $base"
if $digit >= $base;
$acc = $acc * $base + $digit;
}
($acc, $places);
}
token binint {
$0=[ <[ 0..1 ]>+ [ _ <[ 0..1 ]>+ ]* ]
{ make from_base(~$0, 2)[0] }
}
token octint {
$0=[ <[ 0..7 ]>+ [ _ <[ 0..7 ]>+ ]* ]
{ make from_base(~$0, 8)[0] }
}
token hexint {
$0=[ <[ 0..9 a..f A..F ]>+ [ _ <[ 0..9 a..f A..F ]>+ ]* ]
{ make from_base(~$0, 16)[0] }
}
token decint {
$0=[ \d+ [ _ \d+ ]* ]
<?{ make from_base(~$0, 10); True }>
}
token integer {
[
| 0 [ b '_'? <binint> { make $<binint>.ast }
| o '_'? <octint> { make $<octint>.ast }
| x '_'? <hexint> { make $<hexint>.ast }
| d '_'? <decint> { make $<decint>.ast[0] }
| <decint> { make $<decint>.ast[0] }
]
| <decint> { make $<decint>.ast[0] }
]
}
token radint {
[
| <integer> { make $<integer>.ast }
| <?before ':'\d> <rad_number> { make $<rad_number>.ast }
<?{ $() ~~ Int }>
]
}
token escale {
<[Ee]> $0=[<[+\-]>?] <decint>
{ make $0 eq '-' ?? -$<decint>.ast[0] !! $<decint>.ast[0] }
}
token dec_number {
:dba('decimal number')
[
| $<coeff> = [ '.' <frac=.decint> ] <escale>?
| $<coeff> = [<int=.decint> '.' <frac=.decint> ] <escale>?
| $<coeff> = [<int=.decint> ] <escale>
]
{
my $acc = $<int> ?? $<int>.ast[0] !! 0;
if $<frac> -> $f {
my $subn = 10 ** $f.ast[1];
$acc = FatRat.new($acc * $subn + $f.ast[0], $subn);
}
if $<escale> -> $e {
# forces to Num; XXX not exactly rounded!
$acc = $acc * 10e0 ** $e.ast;
}
make $acc;
}
}
token alnumint {
[ <[ 0..9 a..z A..Z ]>+ [ _ <[ 0..9 a..z A..Z ]>+ ]* ]
}
# XXX: accepts _ in radix (STD does not)
token rad_number {
':' <radix=.decint> [ '\\' \s* ]? # XXX optional dot here? **
{} # don't recurse in lexer
:s '<' <radixguts($<radix>.ast[0])> '>'
{ make $<radixguts>.ast }
}
rule radixguts ($r) {
:dba('number in radix notation')
[
| $<coeff> = [ '.' <frac=.alnumint> ]
| $<coeff> = [<int=.alnumint> '.' <frac=.alnumint> ]
| $<coeff> = [<int=.alnumint> ]
]
[
'*' <base=.radint>
[ '**' <exp=.radint> || { die "Base is missing ** exponent part" } ]
]?
# I don't think we need to parse <circumfix> for the runtime case :)
{
my $acc = $<int> ?? from_base(~$<int>, $r)[0] !! 0;
if $<frac> -> $f {
my ($fn, $fp) = from_base(~$f, $r);
my $subn = $r ** $fp;
$acc = FatRat.new($acc * $subn + $fn, $subn);
}
if $<base> -> $b {
# *not* forcing to Num here
$acc = $acc * $b.ast ** $<exp>.ast;
}
make $acc;
}
}
token number {
[
| 'NaN' » { make NaN }
| <integer> { make $<integer>.ast }
| <dec_number> { make $<dec_number>.ast }
| <rad_number> { make $<rad_number>.ast }
| 'Inf' » { make Inf }
]
}
token snumber {
$<sn>=[<[+\-]>?] <.ws> <number>
{ make $<sn> eq '-' ?? -$<number>.ast !! $<number>.ast }
}
# <numeric> is used by Str.Numeric conversions such as those done by val()
# NOTE: allows whitespace for round-tripping
# XXX: allows radix rationals, which strictly speaking it probably shouldn't
token numeric {
[ || $ { make 0 }
|| <re=.snumber>? <.ws>
[ | <?[+\-]> {}:s <im=.snumber>'\\'?'i'
{ make Complex.new($<re> ?? $<re>.ast !! 0, $<im>.ast) }
| '/' {} <.ws> <den=.integer>
{ die "Parsing $/.orig(), rational parts must be integers"
unless $<re>.ast ~~ Int;
make FatRat.new($<re>.ast, $<den>.ast) }
| $ { make $<re>.ast } ] ]
}
method str2num ($str, :$fatrat) {
my ($M) = (token {
<.ws> [ :lang(Niecza::NumSyntax)
<numeric> || { die "Cannot parse number: $str" } ] <.ws>
[ $ || { die "Trailing characters after number at $¢.pos()" } ]
})(Cursor.cursor_start($str, Any));
if $fatrat {
$M<numeric>.ast.FatRat
} else {
my $a = $M<numeric>.ast;
$a ~~ FatRat ?? $a.numerator / $a.denominator !! $a
}
}
method base2num ($str, $base) {
my ($M) = (token {
<.ws> [ :lang(Niecza::NumSyntax)
<radixguts($base)> || {die "Cannot parse :$base: $str" } ] <.ws>
[ $ || { die "Trailing characters after number at $¢.pos()" } ]
})(Cursor.cursor_start($str, Any));
my $a = $M<radixguts>.ast;
$a ~~ FatRat ?? $a.numerator / $a.denominator !! $a
}
}
class Niecza::PseudoStr is Str { has $!value }
role Niecza::Dualvar is Niecza::PseudoStr {
method new($val, Str $str) { Q:CgOp { (dualvar {$val} {self} {$str}) } }
method Str() { self // nextsame; Q:CgOp { (box Str (unbox str (@ {self}))) } }
method gist() { self // nextsame; Q:CgOp { (box Str (unbox str (@ {self}))) } }
method Numeric() { 0 + self }
method perl() { "val({(~self).perl})" }
}
class IntStr is Int does Niecza::Dualvar { }
class RatStr is Rat does Niecza::Dualvar { }
class NumStr is Num does Niecza::Dualvar { }
class ComplexStr is Complex does Niecza::Dualvar { }
sub val($str) is pure {
$_ = Niecza::NumSyntax.str2num($str);
when Num { return NumStr.new($_, $str) }
when Rat { return RatStr.new($_, $str) }
when Int { return IntStr.new($_, $str) }
when Complex { return ComplexStr.new($_, $str) }
fail:
return $str;
CATCH { goto fail; }
}
sub val_nospace($str) is pure {
return Niecza::NumSyntax.str2num($str);
fail:
return $str;
CATCH { goto fail; }
}
# the opposite of Real.base, used for :16($hex_str)
sub unbase(Int:D $base, Cool:D $str) is pure {
if $str ~~ Array {
die ":16[...] syntax NYI";
}
if $str ~~ Numeric {
die 'Numbers may not be passed :base(); if you wanted to render the number in the given base, use $number.base($radix); if you want to treat the number as a string, explicitly coerce it first';
}
$str := ~$str;
if $str ~~ m:pos(0) /\s* [ ':' || '0' (<[bdox]>) <?{ ord($0)-97+10 >= $base }> ] / {
$str.Numeric;
} else {
":{$base}<$str>".Numeric;
}
}
# }}}
# I/O stuff {{{
sub slurp($path?) is unsafe {
if $path {
Q:CgOp { (box Str (slurp (unbox str (@ {$path})))) }
} else {
$*ARGFILES.slurp;
}
}
sub spurt($path,$text) is unsafe { Q:CgOp { (rnull (spurt (unbox str (@ {$path.Str})) (unbox str (@ {$text.Str})))) } }
sub dir($directory = '.', Mu :$test = none('.','..')) is unsafe {
Q:CgOp { (dir (obj_getstr {$directory})) }.grep($test).map({
IO::Path.new(:$directory, :basename($_), :volume(""))
});
}
my class Instant {
has $.val;
method immutable() { True }
method to-posix() { ($!val, False) }
}
sub term:« now »() {
Instant.new( val => Q:CgOp { (now) } );
}
sub times() { Q:CgOp { (times) } }
sub term:« time »() { Q:CgOp { (now) } }
sub term:« rand »() { Q:CgOp { (rand) } }
sub srand($seed?) {
if $seed.defined {
Q:CgOp { (rnull (srand (cast int (obj_getnum {$seed})))) }
} else {
Q:CgOp { (rnull (srand_time)) }
}
}
my class IO {
has $.path; # Str
method Str() { $.path }
method IO() { self }
method slurp() { slurp $.path }
method spurt($text) { spurt $.path, $text }
method combine(*@paths) {
die "Sorry, paths do not form a monoid." unless @paths;
my $acc = shift(@paths).IO;
for @paths { $acc = $acc.append($_) }
$acc
}
method perl() { $.path.perl ~ ".IO" }
method f() is unsafe { Q:CgOp { (box Bool (path_file_exists (obj_getstr {$!path}))) } }
method d() is unsafe { Q:CgOp { (box Bool (path_dir_exists (obj_getstr {$!path}))) } }
method e() is unsafe { Q:CgOp { (box Bool (path_any_exists (obj_getstr {$!path}))) } }
method r() is unsafe { Q:CgOp { (box Bool (path_eaccess_readable (obj_getstr {$!path}))) } }
method R() is unsafe { Q:CgOp { (box Bool (path_access_readable (obj_getstr {$!path}))) } }
method w() is unsafe { Q:CgOp { (box Bool (path_eaccess_writable (obj_getstr {$!path}))) } }
method W() is unsafe { Q:CgOp { (box Bool (path_access_writable (obj_getstr {$!path}))) } }
method x() is unsafe { Q:CgOp { (box Bool (path_eaccess_executable (obj_getstr {$!path}))) } }
method X() is unsafe { Q:CgOp { (box Bool (path_access_executable (obj_getstr {$!path}))) } }
method o() is unsafe { Q:CgOp { (box Bool (path_eaccess_owned (obj_getstr {$!path}))) } }
method O() is unsafe { Q:CgOp { (box Bool (path_access_owned (obj_getstr {$!path}))) } }
method relative($base) { $base.IO.append(self) }
method append($sub) { Q:CgOp { (box Str (path_combine (obj_getstr {self}) (obj_getstr {$sub}))) }.IO }
method but-extension($ext) { Q:CgOp { (box Str (path_change_ext (obj_getstr {self}) (obj_getstr {$ext}))) }.IO }
method realpath() is unsafe { Q:CgOp { (box Str (path_realpath (obj_getstr {self}))) }.IO }
method modified() is unsafe { Instant.new(val => Q:CgOp { (path_modified (obj_getstr {self})) }) }
method copy($dest) is unsafe { Q:CgOp { (rnull (path_copy (obj_getstr {self}) (obj_getstr {$dest})))}}
method chmod($mode) is unsafe { Q:CgOp { (box Int (path_chmod (obj_getstr {self}) (obj_getnum {$mode}))) } }
}
role IO::FileTestable {
method f() is unsafe { Q:CgOp { (box Bool (path_file_exists (obj_getstr {~self}))) } }
method d() is unsafe { Q:CgOp { (box Bool (path_dir_exists (obj_getstr {~self}))) } }
method e() is unsafe { Q:CgOp { (box Bool (path_any_exists (obj_getstr {~self}))) } }
method r() is unsafe { Q:CgOp { (box Bool (path_eaccess_readable (obj_getstr {~self}))) } }
method R() is unsafe { Q:CgOp { (box Bool (path_access_readable (obj_getstr {~self}))) } }
method w() is unsafe { Q:CgOp { (box Bool (path_eaccess_writable (obj_getstr {~self}))) } }
method W() is unsafe { Q:CgOp { (box Bool (path_access_writable (obj_getstr {~self}))) } }
method x() is unsafe { Q:CgOp { (box Bool (path_eaccess_executable (obj_getstr {~self}))) } }
method X() is unsafe { Q:CgOp { (box Bool (path_access_executable (obj_getstr {~self}))) } }
method o() is unsafe { Q:CgOp { (box Bool (path_eaccess_owned (obj_getstr {~self}))) } }
method O() is unsafe { Q:CgOp { (box Bool (path_access_owned (obj_getstr {~self}))) } }
# method l() {
# nqp::p6bool(pir::new__Ps('File').is_link(nqp::unbox_s(self.Str)))
# }
# method s() {
# self.e
# && nqp::p6box_i( nqp::stat(nqp::unbox_s(self.Str),
# nqp::const::STAT_FILESIZE) );
# }
method z() { self.e && self.s == 0; }
# method modified() {
# nqp::p6box_i(nqp::stat(nqp::unbox_s(self.Str), nqp::const::STAT_MODIFYTIME));
# }
#
# method accessed() {
# nqp::p6box_i(nqp::stat(nqp::unbox_s(self.Str), nqp::const::STAT_ACCESSTIME));
# }
#
# method changed() {
# nqp::p6box_i(nqp::stat(nqp::unbox_s(self.Str), nqp::const::STAT_CHANGETIME));
# }
}
class IO::Path is Cool does IO::FileTestable {
# method SPEC { IO::Spec.MODULE };
has Str $.basename;
has Str $.directory = '.';
has Str $.volume = '';
method dir() {
die "IO::Path.dir is deprecated in favor of .directory";
}
submethod BUILD(:$!basename, :$!directory, :$!volume, :$dir) {
die "Named paramter :dir in IO::Path.new deprecated in favor of :directory"
if defined $dir;
}
multi method new(Str:D $path) {
# This seems hacky, but mono's GetFileName and GetDirectoryName
# react weirdly to '/'
if $path eq '/' {
self.bless(:basename(""),
:directory($path),
:volume(""));
} else {
self.bless(:basename(Q:CgOp { (box Str (path_get_file_name (obj_getstr {$path}))) }),
:directory(Q:CgOp { (box Str (path_get_directory_name (obj_getstr {$path}))) }),
:volume(""));
}
}
multi method Str(IO::Path:D:) {
sub Combine($a, $b) {
Q:CgOp { (box Str (path_combine (obj_getstr {$a}) (obj_getstr {$b}))) }
}
Combine(Combine($.volume, $.directory), $.basename);
}
method gist() {
self.defined ?? "{self.^name}<{self.Str}>" !! "(IO::Path)";
}
method perl() {
"IO::Path.new(:basename({ self.basename.perl }), :directory({ self.directory.perl }), :volume({ self.volume.perl }))"
}
# multi method Numeric(IO::Path:D:) {
# self.basename.Numeric;
# }
# method Bridge(IO::Path:D:) {
# self.basename.Bridge;
# }
# method Int(IO::Path:D:) {
# self.basename.Int;
# }
method path(IO::Path:D:) {
self;
}
method IO(IO::Path:D:) {
# IO::Handle.new(:path(~self), |%opts);
IO.new(path => ~self);
}
method open(IO::Path:D: *%opts) {
open(~self, |%opts);
}
method contents(IO::Path:D: *%opts) {
dir(~self, |%opts);
}
# method is-absolute {
# $.SPEC.is-absolute(~self);
# }
# method is-relative {
# ! $.SPEC.is-absolute(~self);
# }
# method absolute ($base = $*CWD) {
# return self.new($.SPEC.rel2abs(~self, $base))
# }
# method relative ($relative_to_directory = $*CWD) {
# # return self.new($.SPEC.abs2rel(~self, $relative_to_directory));
# $base.IO.append(~self)
# }
#
# method cleanup {
# fail "Not Yet Implemented";
# # return self.new($.SPEC.canonpath(~self));
# }
# method resolve {
# fail "Not Yet Implemented: requires readlink()";
# }
# method parent {
# if self.is-absolute {
# return self.new($.SPEC.join($.volume, $.directory, ''));
# }
# elsif all($.basename, $.directory) eq $.SPEC.curdir {
# return self.new(:$.volume, directory=>$.SPEC.curdir,
# basename=>$.SPEC.updir);
# }
# elsif $.basename eq $.SPEC.updir && $.directory eq $.SPEC.curdir
# or !grep({$_ ne $.SPEC.updir}, $.SPEC.splitdir($.directory)) {
# return self.new( # If all updirs, then add one more
# :$.volume,
# directory => $.SPEC.catdir($.directory, $.SPEC.updir),
# :$.basename );
# }
# else {
# return self.new( $.SPEC.join($.volume, $.directory, '') );
# }
# }
# method child ($childname) {
# self.new($.SPEC.join: $.volume,
# $.SPEC.catdir($.directory, $.basename),
# $childname);
# }
}
my class TextReader {
method get() {
Q:CgOp {
(letn line (treader_getline (unbox treader (@ {self})))
(ternary (== (l line) (null str)) {Str} (box Str (l line))))
};
}
method slurp() {
Q:CgOp { (box Str (treader_slurp (unbox treader (@ {self})))) }
}
method getc() {
Q:CgOp {
(letn chi (treader_getc (unbox treader (@ {self})))
(ternary (>= (l chi) (int 0))
(box Str (str_chr (l chi)))
{Str}))
};
}
method lines($given-limit = *) {
my $limit = $given-limit ~~ Whatever ?? Inf !! $given-limit;
gather take my $l while $limit-- > 0 && ($l = self.get).defined;
}
method close() {
Q:CgOp { (rnull (treader_close (unbox treader (@ {self})))) }; True
}
}
my class TextWriter {
method say(*@c) {
# $PROCESS::OUTPUT_USED := True;
Q:CgOp { (rnull (twriter_puts (unbox twriter (@ {self})) (obj_getstr {Niecza::gistcat(|@c) ~ "\n"}))) };
True;
}
method print(*@c) {
# $PROCESS::OUTPUT_USED := True;
Q:CgOp { (rnull (twriter_puts (unbox twriter (@ {self})) (obj_getstr {@c.join("")}))) };
True;
}
method close() {
Q:CgOp { (rnull (twriter_close (unbox twriter (@ {self})))) }; True
}
}
# the following class stolen from Rakudo, but butchered
class IO::ArgFiles {
has $!args;
has $!reader;
method get() {
unless defined $!args {
$!args = [ @*ARGS ];
$!reader = $*IN unless $!args;
}
again:
$!reader //= open(shift($!args) // return Str);
if defined my $line = $!reader.get {
return $line;
} else {
$!reader = Any;
goto again;
}
}
method lines() {
gather take my $l while ($l = self.get).defined;
}
method slurp() {
self.lines.join("\n");
}
}
sub unlink(*@filenames) is unsafe {
for @filenames -> $filename {
if $filename.IO ~~ :d {
Q:CgOp { (box Int (path_rmdir (obj_getstr {$filename}))) };
} else {
Q:CgOp { (rnull (path_unlink (obj_getstr {$filename}))) };
}
}
True; # is there a way to actually detect problems with File.Delete?
}
sub cwd() is unsafe {
Q:CgOp { (box Str (cwd_path)) };
}
sub chdir($filename) is unsafe {
my $ok_code = True;
{
Q:CgOp { (rnull (path_chdir (obj_getstr {$filename}))) };
$PROCESS::CWD ::= Q:CgOp { (box Str (cwd_path)) };
CATCH { default { $ok_code = False; } }
}
$ok_code;
}
sub mkdir($filename) is unsafe {
Q:CgOp { (rnull (path_mkdir (obj_getstr {$filename}))) };
True; # is there a way to actually detect problems with path_mkdir?
}
sub rmdir($filename) is unsafe {
Q:CgOp { (box Int (path_rmdir (obj_getstr {$filename}))) } == 0;
}
sub shell($command) is unsafe {
Q:CgOp { (box Int (command_system (obj_getstr {$command}))) };
}
sub run(*@argv, :%env = %*ENV) is unsafe {
my @env = %env.map({ .key ~ "=" ~ .value });
Q:CgOp { (box Int (command_run {@argv} {@env})) };
}
multi sub open($filename, :$w?, :$a?, :$r?, :$rw?) is unsafe {
die "Not yet able to open both :r and :w" if ($r && $w) || $rw;
if $a {
Q:CgOp { (box TextWriter (twriter_append (obj_getstr {$filename}) (obj_getbool {True}))) }
} elsif $w {
Q:CgOp { (box TextWriter (twriter_open (obj_getstr {$filename}))) }
} else {
Q:CgOp { (box TextReader (treader_open (obj_getstr {$filename}))) }
}
}
sub close($file) {
$file.close;
}
# TODO $*ARGFILES, multi
sub get($handle = $*IN) { $handle.get }
sub lines($filehandle = $*IN, $limit = *) { $filehandle.lines($limit) }
sub prompt($msg) { print $msg; $*IN.get }
sub getc($handle) { $handle.getc }
multi sub log($x) { $x.log }
multi sub log($x, $base) { $x.log($base) }
sub log10($x) is pure { $x.log(10) }
sub unpolar($mag, $angle) is pure { Complex.new($mag * $angle.cos, $mag * $angle.sin); }
sub cis($angle) is pure { Complex.new($angle.cos, $angle.sin); }
sub roots($x, $an) {
my $n = $an.Int;
return NaN if $n < 1;
return $x if $n == 1;
# for $!re, $!im {
# return $NaN if $_ eq 'Inf' || $_ eq '-Inf' || $_ eq 'NaN';
# }
my ($mag, $angle) = $x.polar;
$mag **= 1e0 / $n;
(^$n).map: { $mag.unpolar( ($angle + $_ * 2e0 * pi) / $n) };
}
sub sin($x) is pure { $x.sin }
sub asin($x) is pure { $x.asin }
sub cos($x) is pure { $x.cos }
sub acos($x) is pure { $x.acos }
sub tan($x) is pure { $x.tan }
sub atan($x) is pure { $x.atan }
sub sec($x) is pure { $x.sec }
sub asec($x) is pure { $x.asec }
sub cosec($x) is pure { $x.cosec }
sub acosec($x) is pure { $x.acosec }
sub cotan($x) is pure { $x.cotan }
sub acotan($x) is pure { $x.acotan }
sub sinh($x) is pure { $x.sinh }
sub asinh($x) is pure { $x.asinh }
sub cosh($x) is pure { $x.cosh }
sub acosh($x) is pure { $x.acosh }
sub tanh($x) is pure { $x.tanh }
sub atanh($x) is pure { $x.atanh }
sub sech($x) is pure { $x.sech }
sub asech($x) is pure { $x.asech }
sub cosech($x) is pure { $x.cosech }
sub acosech($x) is pure { $x.acosech }
sub cotanh($x) is pure { $x.cotanh }
sub acotanh($x) is pure { $x.acotanh }
sub atan2($y, $x = 1) is pure { $y.atan2($x) }
sub hypot($a, $b) is pure {
my $max = $a.abs max $b.abs;
my $min = $a.abs min $b.abs;
my $r = $min / $max;
$max * sqrt(1 + $r * $r);
}
sub gamma($x) is pure { $x.gamma }
sub lgamma($x) is pure { $x.lgamma }
sub expm1($x) is pure { $x.expm1 }
sub log1p($x) is pure { $x.log1p }
sub erf($x) is pure { $x.erf }
sub expmod($exp, $power, $mod) is pure { Q:CgOp { (expmod {$exp.Int} {$power.Int} {$mod.Int}) } }
sub is-prime($candidate, $tries = 100) {
# Miller-Rabin via TimToady
my Int $n = $candidate.Int;
my Int $k = $tries.Int;
my @a;
given $n {
when 2 | 3 | 5 | 7 | 11 { return True; }
when * < 2 { return False; }
when * %% 2 { return False; }
when * < 1_373_653 { @a = 2, 3; }
when * < 9_080_191 { @a = 31, 73; }
when * < 4_759_123_141 { @a = 2, 7, 61; }
when * < 2_152_302_898_747 { @a = 2, 3, 5, 7, 11; }
when * < 3_474_749_660_383 { @a = 2, 3, 5, 7, 11, 13; }
when * < 341_550_071_728_321 { @a = 2, 3, 5, 7, 11, 13, 17; }
default { @a = (2 ..^ $n).pick($k); }
}
my Int $d = $n - 1;
my Int $s = 0;
while $d %% 2 {
$d div= 2;
$s++;
}
for @a -> $a {
my $x = expmod($a, $d, $n);
next if $x == 1 | $n - 1;
for 1 ..^ $s {
$x = $x ** 2 mod $n;
return False if $x == 1;
last if $x == $n - 1;
}
return False if $x !== $n - 1;
}
return True;
}
sub pick($num, *@values) { @values.pick($num) }
sub roll($num, *@values) { @values.roll($num) }
sub rotate(@array, $n = 1) { @array.rotate($n) }
sub reduce($expression, *@values) { @values.reduce($expression) }
my sub MAIN_HELPER() {
# Do we have a MAIN at all?
my $m = CALLER::<&MAIN>;
return unless $m;
# Convert raw command line args into positional and named args for MAIN
my sub process-cmd-args (@args is copy) {
my (@positional-arguments, %named-arguments);
while (@args) {
my $passed-value = @args.shift;
if $passed-value ~~ /^ ( '--' | '-' | ':' ) ('/'?) (<-[0..9\.]> .*) $/ {
my ($switch, $negate, $arg) = (~$0, ?((~$1).chars), ~$2); #OK not used
if $arg.index('=').defined {
my ($name, $value) = $arg.split('=', 2);
$value = val($value);
$value = $value but False if $negate;
%named-arguments.push: $name => $value;
} else {
%named-arguments.push: $arg => !$negate;
}
} else {
@args.unshift($passed-value) unless $passed-value eq '--';
@positional-arguments.push: @args.map: &val;
last;
}
}
return \(|@positional-arguments, |%named-arguments);
}
# Generate $?USAGE string (default usage info for MAIN)
my sub gen-usage () {
my @help-msgs;
my $prog-name = $*PROGRAM_NAME eq '-e' ?? "-e '...'" !! $*PROGRAM_NAME;
for $m.candidates -> $sub {
my (@required-named, @optional-named, @positional);
for $sub.signature.params -> $param {
my $argument;
if $param.named {
my @names = $param.named_names.reverse;
$argument = @names.map({($^n.chars == 1 ?? '-' !! '--') ~ $^n}).join('|');
$argument ~= "=<{$param.type.^name}>" unless $param.type === Bool;
if $param.optional {
@optional-named.push("[$argument]");
}
else {
@required-named.push($argument);
}
}
else {
my $constraints = $param.value_constraint_list;
$argument = $constraints ?? $constraints !!
$param.name ?? '<' ~ $param.name.substr(1) ~ '>' !!
'<' ~ $param.type.^name ~ '>' ;
$argument = "[$argument ...]" if $param.slurpy;
$argument = "[$argument]" if $param.optional;
@positional.push($argument);
}
}
my $msg = join(' ', $prog-name, @required-named, @optional-named, @positional);
@help-msgs.push($msg);
}
my $usage = "Usage:\n" ~ @help-msgs.map(' ' ~ *).join("\n");
return $usage;
}
# Process command line arguments
my $cap = process-cmd-args(@*ARGS);
# Generate default $?USAGE message
my $USAGE = gen-usage();
# If dispatch to MAIN is possible, do so
if $m.candidates_matching(|$cap).elems {
return $m(|$cap);
}
# We could not find the correct MAIN to dispatch to!
# Let's try to run a user defined USAGE sub
my $h = CALLER::<&USAGE>;
return $h() if $h;
# We could not find a user defined USAGE sub!
# Let's display the default USAGE message
if ($cap.hash<help>) {
$*OUT.say($USAGE);
exit 1;
}
else {
$*ERR.say($USAGE);
exit 2;
}
}
INIT {
$PROCESS::IN ::= Q:CgOp { (box TextReader (treader_stdin)) };
$PROCESS::OUT ::= Q:CgOp { (box TextWriter (twriter_stdout)) };
$PROCESS::ERR ::= Q:CgOp { (box TextWriter (twriter_stderr)) };
$PROCESS::ARGFILES ::= IO::ArgFiles.new;
@PROCESS::ARGS = Q:CgOp { (sysquery (i 0)) };
%PROCESS::ENV = Q:CgOp { (sysquery (i 4)) };
$PROCESS::EXECUTABLE_NAME ::= Q:CgOp { (sysquery (i 2)) };
$PROCESS::PROGRAM_NAME ::= Q:CgOp { (sysquery (i 1)) };
$PROCESS::BASE_DIRECTORY ::= Q:CgOp { (sysquery (i 3)) };
$PROCESS::OS ::= Q:CgOp { (sysquery (i 5)) };
$PROCESS::CWD ::= Q:CgOp { (box Str (cwd_path)) };
%PROCESS::CUSTOM_LIB ::= { home => Q:CgOp { (sysquery (i 7)) } ~ "/niecza" } ;
@GLOBAL::INC = ();
}
# }}}
# Network {{{
class IO::Socket::INET {
has $!sock;
has Str $!buffer = '';
# TODO: This code is horribly broken, especially if a character gets cut by
# a buffer or packet boundry, or you want to switch from char to binary mode
# doing it right seems to require some kind of Decoder class
method recv (Cool $chars = Inf) {
die('Socket not available') unless $!sock;
if $!buffer.chars < $chars {
$!buffer ~= self.read(2048).decode('UTF-8');
}
if $!buffer.chars > $chars {
my $rec = $!buffer.substr(0, $chars);
$!buffer = $!buffer.substr($chars);
$rec
} else {
my $rec = $!buffer;
$!buffer = '';
$rec;
}
}
method read(IO::Socket::INET:D: Cool $bufsize) {
die('Socket not available') unless $!sock;
Q:CgOp { (box Buf (socket_read (unbox socket {$!sock}) (unbox int {$bufsize.Int}))) }
}
#method poll(Int $bitmask, $seconds) {
# $!sock.poll(
# nqp::unbox_i($bitmask), nqp::unbox_i($seconds.floor),
# nqp::unbox_i((($seconds - $seconds.floor) * 1000).Int)
# );
#}
method send (Cool $string) {
self.write($string.encode('UTF-8'));
}
method write(Buf:D $buf) {
die('Socket not available') unless $!sock;
Q:CgOp { (rnull (socket_write (unbox socket {$!sock}) (unbox blob {$buf}))) }
}
method close () {
die("Not connected!") unless $!sock;
Q:CgOp { (rnull (socket_close (unbox socket {$!sock}))) };
$!sock = Any;
}
my module sock {
# XXX these constants are backend-sensitive.
constant PF_LOCAL = 0;
constant PF_UNIX = 1;
constant PF_INET = 2;
constant PF_INET6 = 0x17;
#constant PF_MAX = 4;
#constant SOCK_PACKET = 0;
constant SOCK_STREAM = 1;
constant SOCK_DGRAM = 2;
constant SOCK_RAW = 3;
constant SOCK_RDM = 4;
constant SOCK_SEQPACKET = 5;
constant SOCK_MAX = 6;
constant PROTO_TCP = 6;
constant PROTO_UDP = 17;
}
has Str $.host;
has Int $.port = 80;
has Str $.localhost;
has Int $.localport;
has Bool $.listen;
has $.family = sock::PF_INET;
has $.proto = sock::PROTO_TCP;
has $.type = sock::SOCK_STREAM;
has Str $.input-line-separator is rw = "\n";
has Int $.ins = 0;
my sub v4-split($uri) {
return $uri.split(':', 2);
}
my sub v6-split($uri) {
my ($host, $port) = ($uri ~~ /^'[' (.+) ']' \: (\d+)$/)[0,1];
return $host ?? ($host, $port) !! $uri;
}
method new (*%args is copy) {
die "Nothing given for new socket to connect or bind to" unless %args<host> || %args<listen>;
if %args<host> {
my ($host, $port) = %args<family> && %args<family> == sock::PF_INET6()
?? v6-split(%args<host>)
!! v4-split(%args<host>);
if $port {
%args<port> //= $port;
%args<host> = $host;
}
}
if %args<localhost> {
my ($peer, $port) = %args<family> && %args<family> == sock::PF_INET6()
?? v6-split(%args<localhost>)
!! v4-split(%args<localhost>);
if $port {
%args<localport> //= $port;
%args<localhost> = $peer;
}
}
%args<listen>.=Bool if %args<listen> :exists;
#TODO: Learn what protocols map to which socket types and then determine which is needed.
self.bless(|%args)!initialize()
}
method !initialize() {
$!sock = Q:CgOp { (box Any (socket_new (unbox int {$.family}) (unbox int {$.type}) (unbox int {$.proto}))) };
#Quoting perl5's SIO::INET:
#If Listen is defined then a listen socket is created, else if the socket type,
#which is derived from the protocol, is SOCK_STREAM then connect() is called.
if $.listen || $.localhost || $.localport {
Q:CgOp { (rnull (socket_bind (unbox socket {$!sock}) (unbox str {$.localhost || "0.0.0.0"}) (unbox int {$.localport || 0}))) };
}
if $.listen {
Q:CgOp { (rnull (socket_listen (unbox socket {$!sock}) (unbox int {20}))) };
}
elsif $.type == sock::SOCK_STREAM {
Q:CgOp { (rnull (socket_connect (unbox socket {$!sock}) (unbox str {$.host}) (unbox int {$.port}))) };
}
self;
}
method get() {
++$!ins;
my $inbuf = '';
my $irs = $!input-line-separator;
my $irslen = chars($irs);
until substr($inbuf, chars($inbuf)-$irslen, $irslen) eq $irs {
$inbuf ~= (self.recv(1) || return $inbuf);
}
substr($inbuf, 0, chars($inbuf)-$irslen);
}
method lines() {
gather { take self.get() };
}
method !setsock($ns) {
$!sock = $ns;
$!buffer = '';
self;
}
method accept() {
my $new_sock := self.WHAT.bless(:$!family, :$!proto, :$!type);
$new_sock!setsock( Q:CgOp { (box Any (socket_accept (unbox socket {$!sock}))) } );
}
#method remote_address() {
# return nqp::p6box_s(nqp::getattr(self, $?CLASS, '$!sock').remote_address());
#}
#method local_address() {
# return nqp::p6box_s(nqp::getattr(self, $?CLASS, '$!sock').local_address());
#}
}
# }}}
{YOU_ARE_HERE}
Jump to Line
Something went wrong with that request. Please try again.