Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: e52d6c3337
Fetching contributors…

Cannot retrieve contributors at this time

3918 lines (3477 sloc) 134.988 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 { ... }
my class ObjAt { ... }
my class Proxy { ... }
my class KeySet { ... }
my class Bag { ... }
my class KeyBag { ... }
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 caller() { Q:CgOp { (frame_caller (frame_caller (callframe))) } }
sub callframe() { Q:CgOp { (frame_caller (callframe)) } }
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 }
method bless($, *%_) { Q:CgOp { (default_new (@ {self}) (unbox varhash (@ {%_}))) } }
method CREATE() { Q:CgOp { (obj_newblank (obj_llhow (@ {self}))) } }
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 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;
}
}
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 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 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 $/) {Match})) };
Match;
}
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 capitalize() { self.lc.subst(:g, /\w+/, { ucfirst $/ }) }
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 bytes() { chars(self) * 2 }
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 flip() { Q:CgOp { (box Str (str_flip (obj_getstr {self}))) }}
method ucfirst() { ucfirst(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);
}
}
my role Positional { Any }
my role Associative { Any }
my class Nil is Cool {
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() { '' }
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 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;
}
}
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) }
method perl() { defined(self) ?? "<" ~ self.numerator ~ "/" ~ self.denominator ~ ">" !! self.typename }
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) }
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 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 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) ~ '"'
}
}
# 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) }
}
# }}}
# Fundamental scalar operators {{{
sub infix:<~> is Niecza::absprec<r= list> is pure (\|$bits) { Q:CgOp {
(letn buf (strbuf_new)
i (int 0)
ar (unbox fvarlist (@ {$bits}))
max (fvarlist_length (l ar))
[whileloop 0 0 (< (l i) (l max)) (prog
[strbuf_append (l buf)
(obj_getstr (fvarlist_item (l i) (l ar)))]
[l i (+ (l i) (int 1))])]
[box Str (strbuf_seal (l buf))])
} }
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 = ''; # XXX use strbuf
while $i >= 1 {
$i--;
$j ~= $str;
}
$j;
}
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 chop($string) is pure { (~$string).chop }
sub chomp($string) is pure { (~$string).chomp }
sub capitalize($string) is pure { (~$string).capitalize }
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 ucfirst($o) is pure { my $s = ~$o; uc(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 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 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 = '') {
my $t;
for unitem(self) -> $x {
$t = (defined($t) ?? ($t ~ $sep ~ $x) !! ~$x);
}
$t // '';
}
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 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 end() { self.elems - 1 }
method classify(&test) {
my %result;
for @(self) {
my $k = test $_;
%result{$k} //= [];
%result{$k}.push: $_;
}
%result.pairs;
}
method categorize(&test) {
my %result;
for @(self) {
my @k = test $_;
for @k -> $k {
%result{$k} //= [];
%result{$k}.push: $_;
}
}
%result.pairs;
}
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];
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];
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];
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 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, $e.value);
} else {
$previous = $e;
$has_previous = 1;
}
}
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)
}
}
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 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 (:Increase(-1), :Same(0), :Decrease(1));
class Set does Associative {
has Bool %!elems;
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 at_key($k) { ?(%!elems{$k} // False) }
method exists_key($k) { self.exists($k) }
# Constructor
method new(*@args --> Set) {
my %e;
sub register-arg($arg) {
given $arg {
when Pair { %e{.key} = True; }
when Set | KeySet { for .keys -> $key { %e{$key} = True; } }
when Associative { for .pairs -> $p { register-arg($p); } }
when Positional { for .list -> $p { register-arg($p); } }
default { %e{$_} = True; }
}
}
for @args {
register-arg($_);
}
self.bless(*, :elems(%e));
}
submethod BUILD (%!elems) { }
# Coercions to and from
method postcircumfix:<( )> ($s --> Set) { to-set($s) }
multi to-set (Set $set --> Set) { $set }
multi to-set (KeySet $set --> Set) { Set.new: $set }
multi to-set (Bag $bag --> Set) { Set.new: $bag }
multi to-set (KeyBag $bag --> Set) { Set.new: $bag }
multi to-set (@elems --> Set) { Set.new: @elems }
multi to-set ([*@elems] --> Set) { Set.new: @elems }
multi to-set (%elems --> Set) { Set.new: %elems.keys }
multi to-set ($elem --> Set) { die "Cannot coerce $elem.perl() to a Set; use set($elem.perl()) to create a one-element set" }
submethod Str(Any:D $ : --> Str) { %!elems.keys().join(" ") }
submethod gist(Any:D $ : --> Str) { "set({ %!elems.keys».gist.join(', ') })" }
submethod perl(Any:D $ : --> Str) { 'set(' ~ join(', ', map { .perl }, %!elems.keys) ~ ')' }
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 ∈ Set($b) }
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) { Set($a) ∋ $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 }
proto sub infix:<∪>($, $ --> Set) is equiv(&infix:<X>) {*}
multi sub infix:<∪>(Any $a, Any $b --> Set) { Set($a) ∪ Set($b) }
multi sub infix:<∪>(Set $a, Set $b --> Set) { Set.new: $a.keys, $b.keys }
only sub infix:<(|)>($a, $b) is equiv(&infix:<X>) { $a ∪ $b }
proto sub infix:<∩>($, $ --> Set) is equiv(&infix:<X>) {*}
multi sub infix:<∩>(Any $a, Any $b --> Set) { Set($a) ∩ Set($b) }
multi sub infix:<∩>(Set $a, Set $b --> Set) { Set.new: $a.keys.grep: -> $k { ?$b{$k} } }
only sub infix:<(&)>($a, $b) is equiv(&infix:<X>) { $a ∩ $b }
proto sub infix:<(-)>($, $ --> Set) is equiv(&infix:<X>) {*}
multi sub infix:<(-)>(Any $a, Any $b --> Set) { Set($a) (-) Set($b) }
multi sub infix:<(-)>(Set $a, Set $b --> Set) { Set.new: $a.keys.grep: * ∉ $b }
proto sub infix:<(^)>($, $ --> Set) is equiv(&infix:<X>) {*}
multi sub infix:<(^)>(Any $a, Any $b --> Set) { Set($a) (^) Set($b) }
multi sub infix:<(^)>(Set $a, Set $b --> Set) { ($a (-) $b) ∪ ($b (-) $a) }
# TODO: polymorphic eqv
# multi sub infix:<eqv>(Any $a, Any $b --> Bool) { Set($a) eqv Set($b) }
# multi sub infix:<eqv>(Set $a, Set $b --> Bool) { $a == $b and so $a.keys.all ∈ $b }
proto sub infix:<⊆>($, $ --> Bool) is equiv(&infix:<==>) {*}
multi sub infix:<⊆>(Any $a, Any $b --> Bool) { Set($a) ⊆ Set($b) }
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) { Set($a) ⊂ Set($b) }
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) { Set($a) ⊇ Set($b) }
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) { Set($a) ⊃ Set($b) }
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 KeySet does Associative {
has Bool %!elems;
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 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 --> KeySet) {
my %e;
sub register-arg($arg) {
given $arg {
when Pair { %e{.key} = True; }
when Set | KeySet { for .keys -> $key { %e{$key} = True; } }
when Associative { for .pairs -> $p { register-arg($p); } }
when Positional { for .list -> $p { register-arg($p); } }
default { %e{$_} = True; }
}
}
for @args {
register-arg($_);
}
self.bless(*, :elems(%e));
}
submethod BUILD (%!elems) { }
submethod Str(Any:D $ : --> Str) { %!elems.keys().join(" ") }
submethod gist(Any:D $ : --> Str) { "keyset({ %!elems.keys».gist.join(', ') })" }
submethod perl(Any:D $ : --> Str) { 'KeySet.new(' ~ join(', ', map { .perl }, %!elems.keys) ~ ')' }
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) }
}
role Baggy { Any }
class Bag does Associative does Baggy {
has Int %!elems; # should be UInt
method keys { %!elems.keys }
method values { %!elems.values }
method elems returns Int { [+] self.values }
method exists($a) returns Bool { %!elems.exists($a) }
method Bool { %!elems.Bool }
method Numeric { self.elems }
method hash { %!elems.hash }
method at_key($k) { +(%!elems{$k} // 0) }
method exists_key($k) { self.exists($k) }
# Constructor
method new(*@args --> Bag) {
my %e;
sub register-arg($arg) {
given $arg {
when Pair { if .value { if %e{.key}:exists { %e{.key} += .value } else { %e{.key} = .value } } }
when Set | KeySet { for .keys -> $key { %e{$key}++; } }
when Associative { for .pairs -> $p { register-arg($p) } }
when Positional { for .list -> $p { register-arg($p) } }
default { %e{$_}++; }
}
}
for @args {
register-arg($_);
}
self.bless(*, :elems(%e));
}
submethod BUILD (%!elems) { }
submethod Str(Any:D $ : --> Str) { %!elems.pairs.map({ $_.key xx $_.value }).flat.join(" ") }
submethod gist(Any:D $ : --> Str) { "bag({ self.pairs>>.gist.join(', ') })" }
submethod perl(Any:D $ : --> Str) { 'Bag.new(' ~ %!elems.perl ~ ')' }
method iterator() { %!elems.pairs.iterator }
method list() { %!elems.keys }
method pairs() { %!elems.pairs }
method pick($count = 1) { my $kb = KeyBag.new(self); $kb.pick($count); }
method roll($count = 1) { my $kb = KeyBag.new(self); $kb.roll($count); }
}
sub bag(*@a) {
Bag.new(|@a);
}
multi sub infix:<∪>(Baggy $a, Any $b --> Bag) { $a ∪ bag($b) }
multi sub infix:<∪>(Any $a, Baggy $b --> Bag) { bag($a) ∪ $b }
multi sub infix:<∪>(Baggy $a, Baggy $b --> Bag) { bag((set($a) ∪ set($b)).map({ ; $_ => $a{$_} max $b{$_} })) }
multi sub infix:<∩>(Baggy $a, Any $b --> Bag) { $a ∩ bag($b) }
multi sub infix:<∩>(Any $a, Baggy $b --> Bag) { bag($a) ∩ $b }
multi sub infix:<∩>(Baggy $a, Baggy $b --> Bag) { bag((set($a) ∪ set($b)).map({ ; $_ => $a{$_} min $b{$_} })) }
proto sub infix:<⊍>($, $ --> Bag) is equiv(&infix:<X>) {*}
multi sub infix:<⊍>(Any $a, Any $b --> Bag) { bag($a) ⊍ bag($b) }
multi sub infix:<⊍>(Bag $a, Bag $b --> Bag) { bag((set($a) ∪ set($b)).map({ ; $_ => $a{$_} * $b{$_} })) }
only sub infix:<(.)>($a, $b --> Bag) is equiv(&infix:<X>) { $a ⊍ $b }
proto sub infix:<⊎>($, $ --> Bag) is equiv(&infix:<X>) {*}
multi sub infix:<⊎>(Any $a, Any $b --> Bag) { bag($a) ⊎ bag($b) }
multi sub infix:<⊎>(Bag $a, Bag $b --> Bag) { bag((set($a) ∪ set($b)).map({ ; $_ => $a{$_} + $b{$_} })) }
only sub infix:<(+)>($a, $b --> Bag) is equiv(&infix:<X>) { $a ⊎ $b }
proto sub infix:<≼>($, $ --> Bool) is equiv(&infix:<==>) {*}
multi sub infix:<≼>(Baggy $a, Baggy $b --> Bool) { so all $a.keys.map({ $a{$_} <= $b{$_} }) }
proto sub infix:<≽>($, $ --> Bool) is equiv(&infix:<==>) {*}
multi sub infix:<≽>(Baggy $a, Baggy $b --> Bool) { so all $b.keys.map({ $b{$_} <= $a{$_} }) }
class KeyBag does Associative does Baggy {
has Int %!elems; # should be UInt
method keys { %!elems.keys }
method values { %!elems.values }
method elems returns Int { [+] self.values }
method exists($a) returns Bool { %!elems.exists($a) }
method Bool { %!elems.Bool }
method Numeric { self.elems }
method hash { %!elems.hash }
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 --> KeyBag) {
my %e;
sub register-arg($arg) {
given $arg {
when Pair { if .value { if %e{.key}:exists { %e{.key} += .value } else { %e{.key} = .value } } }
when Set | KeySet { for .keys -> $key { %e{$key}++; } }
when Associative { for .pairs -> $p { register-arg($p) } }
when Positional { for .list -> $p { register-arg($p) } }
default { %e{$_}++; }
}
}
for @args {
register-arg($_);
}
self.bless(*, :elems(%e));
}
submethod BUILD (%!elems) { }
submethod Str(Any:D $ : --> Str) { %!elems.pairs.map({ $_.key xx $_.value }).flat.join(" ") }
submethod gist(Any:D $ : --> Str) { "keybag({ self.pairs>>.gist.join(', ') })" }
submethod perl(Any:D $ : --> Str) { 'KeyBag.new(' ~ %!elems.perl ~ ')' }
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 = KeyBag.new(self);
my $lc = $count ~~ Whatever ?? Inf !! $count;
gather while $temp-bag && $lc-- {
my $choice = $temp-bag.roll;
take $choice;
$temp-bag{$choice}--;
}
}
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 {{{
sub _vivify_array_at_pos(\ary, $ix) {
Q:CgOp { (newvnewarrayvar (class_ref mo Any) {ary} (cast int (obj_getnum {$ix})) (@ {Any})) };
}
my class GatherIterator is IterCursor {
has $.frame;
has $!reify;
method reify() {
my $*nextframe;
$!reify // ($!reify = (
Q:CgOp {
(letn getv (cotake (cast frame (@ {$!frame})))
(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 {
$r ~= $lsm.unsubstituted_text ~ $lsm.substituted_text;
}
$r ~= $lsm.unsubstituted_text;
return $r;
}
# }}}
# 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 })>"
}
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 $/) {Match})
{Match})
};
}
}
my class Grammar is Cursor {
method parse($text, :$rule = "TOP", :$actions) {
my $match = (head grep { $_.to == chars $text },
self.cursor_start($text, $actions)."$rule"()) // Match;
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 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() {
&infix:<,>(RangeIter.new(:current($!excludes_min ?? $!min.succ !! $!min),
:limit($!max), :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 + $elems.rand.floor) !! 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::Increase !! $a > $b ?? Order::Decrease !! 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::Increase if $a == -Inf;
return Order::Decrease if $a == Inf;
}
if $b ~~ Real {
return Order::Increase if $b == Inf;
return Order::Decrease 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;
}
return $a <=> $b;
}
sub infix:<eqv> is equiv<==> (Any $a, Any $b) { ($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) { Q:CgOp { (box Str (command_qx (obj_getstr {$command_line}))) } }
# 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 { Q:CgOp { (box Str (slurp (unbox str (@ {$path})))) } }
sub spew($path,$text) is unsafe { Q:CgOp { (rnull (spew (unbox str (@ {$path.Str})) (unbox str (@ {$text.Str})))) } }
sub dir($directory = '.', Mu :$test = none('.','..')) is unsafe {
grep $test, Q:CgOp { (dir (obj_getstr {$directory})) };
}
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 spew($text) { spew $.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}))) } }
}
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 lines() {
gather take my $l while ($l = self.get).defined;
}
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;
}
}
}
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 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)) };
@GLOBAL::INC = ();
}
# }}}
{YOU_ARE_HERE}
Jump to Line
Something went wrong with that request. Please try again.