CORE.setting

# 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 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}))) } }
    multi method new(*%_) { Q:CgOp { (default_new (@ {self}) (unbox varhash (@ {%_}))) } }
    method clone(*%_) { Q:CgOp { (repr_clone (@ {self}) (unbox varhash (@ {%_}))) } }
    method dispatch:<::>(|) { Q:CgOp { (dispatch_fromtype) } }
    method immutable() { !defined(self) }
    method take() { take self }
    multi method WHICH() { ObjAt.new(str => '', ref => self) }
}

my class Any is Mu {
    method isa(\other) { self.^isa(other) }
    method does(\other) { self.^does(other) }
    method can($method) { self.^can($method) }
    method flat() { @(self) }
    method Numeric() {
        die "Cannot use value like $.typename as a number" if defined(self);
        warn "Use of uninitialized value in numeric context";
        0;
    }

    # This needs a way of taking a user-defined comparison
    # specifier, but AFAIK nothing has been spec'd yet.
    # CHEAT: Almost certainly should be hashed on something
    # other than the stringification of the objects.
    method uniq() {
        my %seen;
        gather for @(self) {
             unless %seen{$_} {
                 take $_;
                 %seen{$_} = 1;
             }
        }
    }

    method kv() {
        my $i = 0;
        gather for @(self) -> \value {
            my $key = $i++;
            take $key;
            take value;
        }
    }

    method keys() {
        my $i = 0;
        gather for @(self) -> $value { #OK not used
            my $key = $i++;
            take $key;
        }
    }

    method values() {
        gather for @(self) -> \value {
            take value;
        }
    }

    method pairs() {
        self.kv.map(-> $key, \value { $key => value; });
    }

    # NOTE: These functions are called by the default postcircumfixes, *after*
    # processing slicing and adverbs.  So you should probably override these
    # instead.  However, for speed, Array, Hash et al override the
    # postcircumfixes instead, and so you can't change their behavior using
    # delete_key and company in subclasses.
    method delete_key($) {
        die "Cannot use hash access on an object of type {self.WHAT.perl}"
    }
    method exists_key($) {
        die "Cannot use hash access on an object of type {self.WHAT.perl}"
    }
    method at_key($) {
        die "Cannot use hash access on an object of type {self.WHAT.perl}"
    }
    method bind_key($, $) {
        die "Cannot use hash access on an object of type {self.WHAT.perl}"
    }

    method at_pos($key) { self.list.at_pos($key) }
    method bind_pos($, $) {
        die "Cannot use hash access on an object of type {self.WHAT.perl}"
    }

    method grep(Mu $sm) { grep $sm, @(self) }
    method map($func)   { map $func, @(self) }
    method for (&cb) {
        Q:CgOp {
            (rnull (letn it (unbox vvarlist (@ {self.iterator}))
                  cb (@ {&cb})
              (whileloop 0 0 (iter_hasflat (l it))
                (sink (subcall (l cb) (vvarlist_shift (l it)))))))
        };
    }
    method elems() { self.flat.elems }
    method 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 chomp() {
        my $s = ~self;
        my $l = chars($s);
        --$l if $l && substr($s, $l-1, 1) eq "\x0A";
        --$l if $l && substr($s, $l-1, 1) eq "\x0D";
        substr($s,0,$l);
    }
    method p5chomp($self is rw:) {
        my $s = ~$self;
        my $l = chars($s);
        my $ol = $l;
        --$l if $l && substr($s, $l-1, 1) eq "\x0A";
        --$l if $l && substr($s, $l-1, 1) eq "\x0D";
        $self = substr($s,0,$l);
        $ol - $l;
    }
    method chop() {
        my $s = ~self;
        substr($s, 0, chars($s) - 1)
    }
    method p5chop($self is rw:) {
        my $str = ~$self;
        return '' if $str eq '';
        my $end = substr($str, chars($str)-1, 1);
        $self = substr($str, 0, chars($str)-1);
        $end;
    }
    method substr(\: $start, $len?, $repl?) {
        $start := $start(chars self) if $start.^does(Code);
        $len := $len.^does(Code) ?? ($len(chars self) - $start) !!
            $len // (chars(self) - $start);
        defined($repl) ??
            substr(self, $start, $len) = $repl !!
            substr(self, $start, $len)
    }
    method lc()   { Q:CgOp { (box Str (str_tolower (obj_getstr {self}))) }}
    method uc()   { Q:CgOp { (box Str (str_toupper (obj_getstr {self}))) }}
    method tc() {
        self ~~ /^(.)(.*)$/ ?? Q:CgOp { (box Str (ucd_titlecase { $0.ord })) } ~ $1 !! "";
    }
    method tclc() {
        self ~~ /^(.)(.*)$/ ?? Q:CgOp { (box Str (ucd_titlecase { $0.ord })) } ~ $1.lc !! "";
    }
    method tcuc() {
        self ~~ /^(.)(.*)$/ ?? Q:CgOp { (box Str (ucd_titlecase { $0.ord })) } ~ $1.uc !! "";
    }
    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 Buf { ... }
my class Str is Cool {
    method new() { "" }
    method immutable() { True }
    method ACCEPTS(\t) { defined(self) ?? self eq t !! t.^does(self) }
    method chars() { chars(self) }
    method IO() { IO.new(path => self) }
    method say() { $*OUT.say(self) }
    multi method WHICH(Str:D:) {
        ObjAt.new(str => ("str|" ~ self), ref => self.WHAT)
    }

    # TODO: Switch to a multi once where is working.
    method indent($steps) {
        my $TABSTOP = CALLER::<$?TABSTOP> // 8;

        if $steps~~Int && $steps == 0 {
            # Zero indent does nothing
            return self;
        } elsif $steps~~Int && $steps > 0 {
            # Positive indent does indent

            # We want to keep trailing \n so we have to .comb explicitly instead of .lines
            return self.comb(/:r ^^ \N* \n?/).map({
                given $_ {
                    # Use the existing space character if they're all the same
                    # (but tabs are done slightly differently)
                    when /^(\t+) ([ \S .* | $ ])/ {
                        $0 ~ "\t" x ($steps div $TABSTOP) ~
                             ' '  x ($steps mod $TABSTOP) ~ $1
                    }
                    when /^(\h) $0* [ \S | $ ]/ {
                        $0 x $steps ~ $_
                    }
    
                    # Otherwise we just insert spaces after the existing leading space
                    default {
                        ($_ ~~ /^(\h*) (.*)$/).join(' ' x $steps)
                    }
                }
            }).join;
        } else {
            # Negative values and Whatever-* do outdent
            # Loop through all lines to get as much info out of them as possible
            my @lines = self.comb(/:r ^^ \N* \n?/).map({
                # Split the line into indent and content
                my ($indent, $rest) = @($_ ~~ /^(\h*) (.*)$/);
    
                # Split the indent into characters and annotate them
                # with their visual size
                my $indent-size = 0;
                my @indent-chars = $indent.comb.map(-> $char {
                    my $width = $char eq "\t"
                        ?? $TABSTOP - ($indent-size mod $TABSTOP)
                        !! 1;
                    $indent-size += $width;
                    $char => $width;
                });
    
                { :$indent-size, :@indent-chars, :$rest };
            });
    
            # Figure out the amount * should outdent by, we also use this for warnings
            my $common-prefix = [min] @lines.map({ $_<indent-size> });

            # Set the actual outdent amount here
            my Int $outdent = $steps ~~ Whatever ?? $common-prefix
                                                 !! -$steps;
            warn sprintf('Asked to remove %d spaces, ' ~
                         'but the shortest indent is %d spaces',
                         $outdent, $common-prefix) if $outdent > $common-prefix;
    
            # Work backwards from the right end of the indent whitespace, removing
            # array elements up to # (or over, in the case of tab-explosion)
            # the specified outdent amount.
            @lines.map({
                my $pos = 0;
                while $_<indent-chars> and $pos < $outdent {
                    $pos += $_<indent-chars>.pop.value;
                }
                $_<indent-chars>».key.join ~ ' ' x ($pos - $outdent) ~ $_<rest>;
            }).join;
        }
    }

    method gist() { defined(self) ?? self !! nextsame }
    method Numeric () { Niecza::NumSyntax.str2num(~self) }
    CHECK my $esc = {
        '$' => '\$',  '@' => '\@',  '%' => '\%',  '&' => '\&',  '{' => '\{',
        "\b" => '\b', "\n" => '\n', "\r" => '\r', "\t" => '\t', '"' => '\"',
        '\\' => '\\\\' };
    method perl() {
        self // nextsame;
        '"' ~ self.subst(/ <[$@%&{\b\cJ\cM\t\"\\]> /, { $esc{$/} }, :g)\
                  .subst(/ <-print> /, { ord($/).fmt('\x[%x]') }, :g) ~ '"'
    }
    method encode(Str $enc) {
        Q:CgOp { (box (@ {Buf}) (encode (unbox str (@ {self})) (obj_getstr {$enc}))) }
    }
}

my class Buf {
    method decode(Str $enc) {
        Q:CgOp { (box Str (decode (unbox blob (@ {self})) (obj_getstr {$enc}))) }
    }
    method elems() {
        Q:CgOp { (box Int (unbox blob (@ {self}))) }
    }
    method bytes() { self.elems }
    method Bool() { ?self.elems }
    method Numeric() { self.elems }
    method Int() { self.elems }
}

# ObjAt in Niecza is the type of return values from WHICH.  It is a comparable
# type that allows any two objects to be compared, and attempts to capture a
# notion of 'essential equality'.  The most ready way to compare the identities
# of mutable objects is to compare references, so ObjAt keeps a reference;
# ObjAt also keeps a string description of contents, for non-mutable types.
#
# For mutable types, the string should be empty, and the reference should be
# the specific object that WHICH was invoked upon.
#
# For defined values of immuable types, the string should hold a description
# of this object, and the reference points to the WHAT of the invokee.
#
# Note that if this protocol is followed, $x === $y implies
# $x.WHAT === $y.WHAT, and so the string data is completely under the control
# of the type.
#
# Well, not quite - you need to avoid returning anything starting with objat|
my class ObjAt {
    has Str $.str;
    has Mu  $.ref;

    multi method WHICH(ObjAt:D:) {
        ObjAt.new(str => 'objat|' ~ $!str, ref => $!ref)
    }

    sub REFHASH($v) { Q:CgOp { (box Int (ref_hash (@ {$v}))) }.fmt('[%X]') }
    method Str()  { self // nextsame; $!str ~ REFHASH($!ref) }
    method gist() { self // nextsame; $!str ~ REFHASH($!ref) }
}

my class Scalar {
}

# just a tag
my role Callable { Any }
my class Code does Callable {
    has $!outer;
    has $!info;

    method outer() { Q:CgOp { (getslot Code $!outer frame (@ {self})) } }
    method perl() { defined(self) ?? '{ ... }' !! self.typename }

    method accepts_capture($cap) { Q:CgOp { (code_accepts_capture (@ {self}) (@ {$cap})) } }
    method candidates(Code:D:) { Q:CgOp { (code_candidates (@ {self})) } }
    method signature(Code:D:)  { Q:CgOp { (code_signature (@ {self})) } }
    method candidates_matching(|cap) { grep *.accepts_capture(cap), self.candidates }
    method name(Code:D:) { Q:CgOp { (box Str (code_name (@ {self}))) } }
}

my class Block is Code {
    method ACCEPTS(\t) { defined(self) ?? (self)(t) !! t.^does(self) }
    method count() { Q:CgOp { (count (@ {self})) } }
    method arity() { Q:CgOp { (arity (@ {self})) } }
}

my class Routine is Block {
    method assuming(|cap) { sub (|new) { self.(|cap, |new) } }
    # wrap, unwrap, cando NYI
    method perl() {
        self // nextsame;
        my $perl = self.^name.lc();
        if self.name() -> $n {
            $perl ~= " $n";
        }
        $perl ~= self.signature().perl.substr(1);
        $perl ~= ' { ... }';
        $perl
    }
}

my class Sub is Routine { }
my class Method is Routine { }
my class Submethod is Routine { }
my class WhateverCode is Block { }

my class Parameter {
    # Value processing
    our constant HASTYPE    = 1;
    our constant MULTI_IGNORED = 16384;
    our constant ANY_DEF    =  0x40000;
    our constant UNDEF_ONLY =  0x80000;
    our constant DEF_ONLY   =  0xC0000;
    our constant TYPE_ONLY  = 0x100000;
    our constant DEF_MASK   = 0x1C0000;

    # Value binding
    our constant READWRITE  = 2;
    our constant RWTRANS    = 8;
    our constant INVOCANT   = 8192;
    our constant IS_COPY    = 32768;
    our constant IS_LIST    = 65536;
    our constant IS_HASH    = 131072;
    our constant CALLABLE   = 0x20_0000;

    # Value source
    our constant HASDEFAULT = 32;
    our constant OPTIONAL   = 64;
    our constant DEFOUTER   = 4096;
    our constant POSITIONAL = 128;
    our constant SLURPY_POS = 256;
    our constant SLURPY_NAM = 512;
    our constant SLURPY_CAP = 1024;
    our constant SLURPY_PCL = 2048;

    method flags(Parameter:D:) { Q:CgOp { (box Int (param_flags (@ {self}))) } }

    method named(Parameter:D:) { ? (self.named_names && !self.positional) }
    method named_names(Parameter:D:) { Q:CgOp { (param_names (@ {self})) } }
    method type(Parameter:D:) { Q:CgOp { (param_type (@ {self})) } }
    method sub_signature(Parameter:D:) { Q:CgOp { (param_subsig (@ {self})) } }
    method optional(Parameter:D:) { ?( self.flags +& (HASDEFAULT +| OPTIONAL) ) }
    method positional(Parameter:D:) { ?( self.flags +& POSITIONAL ) }
##    method value_constraint_list() { !!! }
    method name() { Q:CgOp { (box Str (param_name (@ {self}))) } }
    method slurpy() { ?( self.flags +& (SLURPY_CAP + SLURPY_NAM + SLURPY_POS) ) }

    # no constraint_list!  niecza's SubInfo constraints don't reflect well :|
    method value_constraint_list(Parameter:D:) { Q:CgOp { (param_value_constraints (@ {self})) } }
    method parcel() { ?( self.flags +& RWTRANS ) }
    method capture() { ?( self.flags +& SLURPY_CAP ) }
    method rw() { ?( self.flags +& READWRITE ) }
    method copy() { ?( self.flags +& IS_COPY ) }
    method readonly() { !( self.flags +& (READWRITE + IS_COPY + RWTRANS) ) }
    method invocant() { ?( self.flags +& INVOCANT ) }
##    method default() {  }

    # XXX TODO: A few more bits :-)
    multi method perl(Parameter:D:) {
        my $perl = '';
        my $flags = self.flags;
        my $type = self.type.^name;
        if $flags +& IS_LIST {
            # XXX Need inner type
        }
        elsif $flags +& IS_HASH {
            # XXX Need inner type
        }
        else {
            $perl = $type;
            if $flags +& DEF_ONLY {
                $perl ~= ':D';
            } elsif $flags +& UNDEF_ONLY {
                $perl ~= ':U';
            } elsif $flags +& TYPE_ONLY {
                $perl ~= ':T';
            }
            $perl ~= ' ';
        }
        if self.name -> $name is copy {
            if $flags +& SLURPY_CAP {
                $perl ~= '|' ~ $name;
            } elsif $flags +& RWTRANS {
                $perl ~= '\\' ~ $name;
            } else {
                my $default = $flags +& HASDEFAULT;
                if !self.positional && self.named_names -> @names {
                    my $short = $name.substr(1);
                    $name = ':' ~ $name if $short eq any @names;
                    for @names {
                        next if $_ eq $short;
                        $name = ':' ~ $_ ~ '(' ~ $name ~ ')';
                    }
                    $name ~= '!' unless self.optional;
                } elsif self.optional && !$default {
                    $name ~= '?';
                } elsif self.slurpy {
                    $name = '*' ~ $name;
                }
                $perl ~= $name;
                if $flags +& READWRITE {
                    $perl ~= ' is rw';
                } elsif $flags +& IS_COPY {
                    $perl ~= ' is copy';
                }
                $perl ~= ' = { ... }' if $default;
                if self.sub_signature -> $sub {
                    $perl ~= ' ' ~ $sub.perl;
                }
            }
        }
        $perl
    }
}
my class Signature {
    method params(Signature:D:) { Q:CgOp { (sig_params (@ {self})) } }
    method arity(Signature:D:) { Q:CgOp { (box Int (sig_arity (@ {self}))) } }
    method count(Signature:D:) { Q:CgOp { (box Int (sig_count (@ {self}))) } }
    # XXX TODO: Parameter separators.
    method perl() {
        self // nextsame;
        ':(' ~ join(', ', self.params».perl) ~ ')';
    }
}

my class ClassHOW {
    method name($) { Q:CgOp { (box Str (obj_typename (stab_what (unbox stable (@ {self}))))) } }
    method isa(\obj, \type) { Q:CgOp {
        (box Bool (obj_isa (@ {obj}) (obj_llhow (@ {type}))))
    } }
    method does(\obj, \role) { self.isa(obj, role) }
    method can(\obj, $name) { Q:CgOp {
        (box Bool (obj_can (@ {obj}) (obj_getstr {$name})))
    } }
}

my role CommonEnum {
    has $!index;

    method perl()  {
        defined(self) ?? (self.typename ~ "::" ~ self.key) !! self.typename
    }
    method gist()  { defined(self) ?? self.key !! (self.typename ~ "()") }
    method key()   { self.enums._index_to_key($!index) }
    method value() { self.enums._index_to_value($!index) }
    method kv()    { self.key, self.value }
    method pair()  { self.key => self.value }

    method succ() {
        my $index = defined(self) ?? $!index !! 0;
        return self if $index == self.enums - 1;
        self.from-index($index + 1)
    }

    method pred() {
        my $index = defined(self) ?? $!index !! 0;
        $index ?? self.from-index($index - 1) !! self;
    }

    method from-index($ix) { self._create($ix,self.enums._index_to_value($ix)) }

    method postcircumfix:<( )> ($key) {
        self.from-index(self.enums._lookup($key));
    }

    method pick($count = 1) { self.enums.map({ self.($_.key) }).pick($count) }
    method roll($count = 1) { self.enums.map({ self.($_.key) }).roll($count) }
}

my role IntBasedEnum does CommonEnum {
    method Numeric() { Q:CgOp { (box Int (unbox int (@ {self}))) } }
    method Int() { self.Numeric }
    method Str() { defined(self) ?? self.key !! nextsame }
    method Stringy() { defined(self) ?? self.key !! nextsame }
    method _create($ix,$val) { Q:CgOp {
        (letn obj (box (@ {self}) (unbox int (@ {$val.Int})))
          (setslot (obj_llhow (@ (l obj))) $!index (@ (l obj)) {$ix.Int})
          (l obj))
    } }
}

my role StrBasedEnum does CommonEnum {
    method _create($ix,$val) { Q:CgOp {
        (letn obj (box (@ {self}) (unbox str (@ {$val.Str})))
          (setslot (obj_llhow (@ (l obj))) $!index (@ (l obj)) {$ix.Int})
          (l obj))
    } }
}

# Using the "enum" type declarator would require a compile time reference
# to the EnumMap type, which depends on Bool; ick.
my class Bool is Int does IntBasedEnum {
    our $_enums;
    method enums() { $_enums }
    our constant True = Q:CgOp { (box Bool (bool 1)) };
    our constant False = Q:CgOp { (box Bool (bool 0)) };
    method ACCEPTS(\t) { defined(self) ?? self !! t.^does(self) }
    method succ() { True }
    method pred() { False }
}
# }}}
# Fundamental scalar operators {{{
sub infix:<~> is Niecza::absprec<r= list> is pure (\|$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 tc($string)    is pure { (~$string).tc }
sub tclc($string)  is pure { (~$string).tclc }
sub chop($string)  is pure { (~$string).chop }
sub chomp($string) is pure { (~$string).chomp }
sub 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 caller() { Q:CgOp { (frame_caller (frame_caller (callframe))) } }
sub callframe(Int $level is copy = 0) {
    my $frame := Q:CgOp { (frame_caller (callframe)) };
    $frame := $frame.caller while --$level;
    $frame;
}

sub die($msg = "Died") { Q:CgOp { (die (@ {$msg})) } }

my class Label {
    has $!target;
    has $!name;
    method immutable() { True }

    method goto() { _lexotic(8, self, ()) }
    method next() { _lexotic(1, self, ()) }
    method last() { _lexotic(2, self, ()) }
    method redo() { _lexotic(3, self, ()) }
}

# XXX multi dispatch
sub _lexotic ($id, $x, \val) {
    Q:CgOp {
        (letn fr (null frame)
              nm (null str)
              id (@ {$x})
          (ternary (obj_isa (l id) (class_ref mo Label))
            (prog (l fr (getslot Label $!target frame (l id)))
                  (l nm (getslot Label $!name str (l id))))
            (ternary (obj_isa (l id) (class_ref mo Str))
              (l nm (obj_getstr {$x}))
              (prog)))
          (control (cast int (obj_getnum {$id})) (l fr) (int -1) (l nm) {val}))
    }
}
sub goto ($x)  { _lexotic(8, $x, ()) }

sub nextsame() {
    Q:CgOp { (control 9 (null frame) (int -1) (null str) (null obj)) }
}
sub nextwith(|cap) {
    Q:CgOp { (control 9 (null frame) (int -1) (null str) (@ {cap})) }
}

sub callsame () { Q:CgOp { (callnext (null obj)) } }
sub callwith (|cap) { Q:CgOp { (callnext (@ {cap})) } }

sub assignop($fn) {
    anon sub _assign(\lhs, \rhs) {
        lhs = $fn(lhs, rhs)
    }
}

sub notop(&fn) { -> \x, \y { !(fn(x,y)) } }

# }}}
# Aggregate types {{{
# Parcel: immutable list of boxes which have no context - may flatten, may
# autovivify, don't rebind or push/shift/etc
# List: mutable list of boxes without much context.  accessing off end returns
# undefined.  lazy.
# coercion makes the elements of a List read-only and maybe fetches them too.
# Array: mutable list of read-write scalar boxes

sub unitem(\a) { Q:CgOp { (newrwlistvar (@ {a})) } }
sub head(\x) { for x -> \elt { return elt }; Any }

my class Iterator {
    method list () {
        Q:CgOp {
            (letn n (obj_newblank (class_ref mo List))
              (iter_to_list (l n) (unbox vvarlist (@ {self})))
              (newrwlistvar (l n)))
        }
    }

    method flat () {
        Q:CgOp {
            (letn n (obj_newblank (class_ref mo List))
              (iter_to_list (l n) (iter_flatten (unbox vvarlist (@ {self}))))
              (newrwlistvar (l n)))
        }
    }
}

my class IterCursor {
    # subclasses must provide .reify, return parcel
}

sub flat(*@x) { @x }
sub hash(|cap) {
    (%(cap) || cap.Parcel.raw_elems != 1) ??
        %( @(cap), %(cap) ) !! %( $(cap) )
}

my class EMPTY { }

my class Parcel is Cool does Positional {
    method ACCEPTS(\what) { defined(self) ?? self.flat.ACCEPTS(what) !! nextsame }
    method flat() { self.iterator.flat }
    method at_pos($key) { @(self).[$key] }

    # LoLly usage
    method raw_elems() { Q:CgOp {
        (box Num (cast num (fvarlist_length (unbox fvarlist (@ {self})))))
    } }
    method raw_at($ix) {
        Q:CgOp { (fvarlist_item (cast int (obj_getnum {$ix})) (unbox fvarlist (@ {self}))) }
    }
    method immutable() {
        self // return True;
        my $ix = 0;
        my $max := self.raw_elems;
        while $ix < $max {
            IMMUTABLE(self.raw_at($ix++)) || return False;
        }
        True;
    }

    method unwrap-single(@self:) { Q:CgOp {
        (letn p (unbox fvarlist (@ {@self}))
              l (fvarlist_length (l p))
          (ternary (== (i 0) (l l)) {Nil}
            (ternary (== (i 1) (l l))
              (fvarlist_item (i 0) (l p)) {@self})))
    } }

    method Capture () {
        Q:CgOp {
            (letn n (obj_newblank (obj_llhow (@ {Capture})))
              (setslot Capture $!positionals (l n) (unbox fvarlist (@ {self})))
              (l n))
        }
    }

    method perl(\:) {
        self // return self.typename;
        my @tok;
        push @tok, '$' if !self.flattens;
        push @tok, '(';
        loop (my $i = 0; $i < self.raw_elems; $i++) {
            push @tok, self.raw_at($i).perl;
            push @tok, ', ' unless $i == self.raw_elems - 1 && $i;
        }
        push @tok, ')';
        @tok.join;
    }

    method elems  () { + @(self) }
    method Numeric() { + @(self) }
    method Bool   () { ? @(self) }
    method gist   () {
        self // nextsame;
        my @tok;
        loop (my $i = 0; $i < self.raw_elems; $i++) {
            push @tok, self.raw_at($i).gist;
        }
        @tok.join(" ");
    }

    method 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] // return Inf;
        for @(self) {
            $min = $_ if $cmp($_, $min) < 0;
        }
        $min;
    }

    method max($cmp_ = &infix:<cmp>) {
        my $cmp = $cmp_;
        if $cmp_.count == 1 {
            $cmp = sub (\x, \y) { $cmp_(x) cmp $cmp_(y) }
        }
        my $max = self[0] // return -Inf;
        for @(self) {
            $max = $_ if $cmp($_, $max) > 0;
        }
        $max;
    }

    method minmax($cmp_ = &infix:<cmp>) {
        my $cmp = $cmp_;
        if $cmp_.count == 1 {
            $cmp = sub (\x, \y) { $cmp_(x) cmp $cmp_(y) }
        }
        my $min = self[0] // return Inf .. -Inf;
        my $max = self[0];
        for @(self) {
            $min = $_ if $cmp($_, $min) < 0;
            $max = $_ if $cmp($_, $max) > 0;
        }
        $min..$max;
    }

    method plan(*@items) {
        Q:CgOp {
            (rnull
              (vvarlist_append (getslot List $!rest vvarlist (@ {self}))
                (unbox vvarlist (@ {@items.iterator}))))
        }
    }

    method kv() { my $i = 0; self.map({ $i++, $_ }) }

    method at_pos($p) { self[$p] }

    method fmt($format = '%s', $separator = ' ') {
        self.map({ .fmt($format) }).join($separator);
    }

    method rotate($n = 1) {
        my $k = $n % self.elems;
        self[$k .. self.elems-1, 0 .. $k-1];
    }

    method splice( @array is rw: $offset = 0, $size = Inf, *@values ) {
        my $begin = $offset.^does(Code) ?? $offset.(@array.elems) !! $offset;
        my $max;

        if $size.^does(Code) {
            $max = $size.(@array.elems);
        } elsif $size < 0 {
           die '$size must be non-negative.';
        } else {
            $max = $begin + $size;
        }

        if $max > @array.elems {
            $max = @array.elems;
        }

        if ($begin < 0) {
           die '$offset must be non-negative.';
        }

        if ($max < 0) {
           die '$size must be non-negative.';
        }

        my @retval = @array.delete($begin..^$max);

        my @temp = @array[0..^$begin]; 
        @temp.push(@values);
        @temp.push(@array[$max..^@array.elems]);
        @array = @temp;

        return @retval;
    }
}

my class Array is List {
    method perl(\:) {
        self // return self.typename;
        "[" ~ self.map(*.perl).join(', ') ~ "]" ~ (self.flattens ?? ".list" !! "");
    }

    method delete(*@indices) {
        my @result;
        my @i = @indices.map({
            when Range { $_.iterator.list }
            when Callable { $_(+self) }
            when * < 0 { die "Negative index not allowed, please use WhateverCode" }
            $_;
        });
        for @i -> $i {
            @result.push(self[$i]);
            self[$i] = Any;
        }
        self.pop while ?self && !defined self[*-1];
        return @result;
    }
}

# Not connected to Hash because Stash contains bvalues while Hash
# holds values directly.
my class Stash does Associative {
    method at_key($key)        {
        Q:CgOp { (stash_at_key (@ {self}) (obj_getstr {$key})) } }
    method bind_key($key, \to) {
        Q:CgOp { (stash_bind_key (@ {self}) (obj_getstr {$key}) {to}) } }
    method delete_key($key)    {
        Q:CgOp { (stash_delete_key (@ {self}) (obj_getstr {$key})) } }
    method exists_key($key)    {
        Q:CgOp { (stash_exists_key (@ {self}) (obj_getstr {$key})) } }
}

my class PseudoStash does Associative {
    has $.name;

    method at_key($key)        {
        Q:CgOp { (pstash_at_key (@ {self}) (obj_getstr {$key})) } }
    method bind_key($key, \to) {
        Q:CgOp { (pstash_bind_key (@ {self}) (obj_getstr {$key}) {to}) } }
}

my class Hash does Associative {
    method new() { unitem(Q:CgOp { (box Hash (varhash_new)) }) }

    method any() { any self.keys }
    method none() { none self.keys }
    method all() { all self.keys }
    method one() { one self.keys }

    method Capture () {
        Q:CgOp {
            (letn n (obj_newblank (obj_llhow (@ {Capture})))
              (setslot Capture $!positionals (l n) (fvarlist_new))
              (setslot Capture $!named (l n) (varhash_dup
                  (unbox varhash (@ {self}))))
              (l n))
        }
    }

    method keys()   { Q:CgOp { (hash_keys   {self}) } }
    method values() { Q:CgOp { (hash_values {self}) } }
    method pairs()  { Q:CgOp { (hash_pairs  {self}) } }
    method list()   { Q:CgOp { (hash_pairs  {self}) } }
    method kv()     { Q:CgOp { (hash_kv     {self}) } }

    method Numeric() { +@(self) }
    method Str() { @(self).map(* ~ "\n").join }

    method invert() {
        my @new;
        for self.kv -> $k, $v { push @new, $v => $k }
        @new
    }

    method !array-push(Str $key, Mu $value) {
        if not self{$key}:exists {
            self{$key} = $value;
        } elsif self{$key} ~~ Array {
            self{$key}.push: $value;
        } else {
            self{$key} = [self{$key}, $value];
        }
    }

    method push(*@v) {
        my Mu $previous;
        my $has_previous;
        for @v -> $e {
            if $has_previous {
                self!array-push($previous.Str, $e);
                $has_previous = 0;
            } elsif $e.^isa(Enum) {
                self!array-push($e.key.Str, $e.value);
            } else {
                $previous     = $e;
                $has_previous = 1;
            }
        }
        self;
    }

    # 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.WHAT.gist cmp $b.WHAT.gist) == 0 && ($a cmp $b) == 0 }
sub infix:<before> ($a, $b) is equiv<==> { ($a cmp $b) < 0 }
sub infix:<after> ($a, $b) is equiv<==> { ($a cmp $b) > 0 }
sub seqop($op, \x, \y) { $op(x,y) } # TODO: Special case with hyper
sub reverseop($op, \x, \y) { $op(y, x) }

sub infix:<div> is equiv<*> ($x,$y) is pure { Q:CgOp { (divop (i 4) {$x} {$y}) } }
sub infix:<mod> is equiv<*> ($x,$y) is pure { Q:CgOp { (divop (i 5) {$x} {$y}) } }
sub infix:<~&> ($x, $y) { die "Buffer bitops NYI"; } #OK
sub infix:<~|> ($x, $y) { die "Buffer bitops NYI"; } #OK
sub infix:<~^> ($x, $y) { die "Buffer bitops NYI"; } #OK
sub infix:«~<» ($x, $y) { die "Buffer bitops NYI"; } #OK
sub infix:«~>» ($x, $y) { die "Buffer bitops NYI"; } #OK
sub prefix:<~^> ($x) { die "Buffer bitops NYI"; } #OK
sub prefix:<||> (\|$args) { die "Slicels NYI" } #OK
sub postfix:<i> ($item) is pure is fiddly is uassoc<left> { $item ~~ Complex ?? $item * i !! Complex.new(0, $item) }
sub prefix:<sleep> ($x) { Q:CgOp { (sleep (obj_getnum {$x})) } }
sub infix:<...> is equiv<X> (\|$lists) { &Niecza::series-listop($lists, False) }
sub infix:<...^> is equiv<X> (\|$lists) { &Niecza::series-listop($lists, True) }
sub infix:« ==> »(\|$args) { die "Feed ops NYI" } #OK
sub infix:« ==>> »(\|$args) { die "Feed ops NYI" } #OK
sub infix:« <== »(\|$args) { die "Feed ops NYI" } #OK
sub infix:« <<== »(\|$args) { die "Feed ops NYI" } #OK

sub eval($str,:$lang="perl6") is return-pass {
    if $lang eq "perl6" {
        Q:CgOp { (simple_eval {$str}) }
    } else {
        Q:CgOp { (eval_perl5 {$str}) }
    }
}

sub rungather($command_line) { Q:CgOp { (box Str (command_qx (obj_getstr {$command_line}))) } }

# tiny stub for Dancer
my class DateTime {
    has $!now;
    method new($now) {
        self := self.bless(*);
        $!now = $now;
        self;
    }
    method Str() { $!now }
}

# a rather strange grammar.  All of its rules are tokens, and some of them
# will die().
grammar Niecza::NumSyntax {
    # this is a high candidate to be rewritten in C#
    sub from_base(Str $str, Int $base) {
        my $acc = 0;
        my $places = 0;
        my $ch;
        my $digit;
        loop (my $ix = 0; $ix < chars($str); ++$ix) {
            $ch = ord(substr($str,$ix,1));
            $ch == 0x5F and next;
            ++$places;
            0x30 <= $ch <= 0x39 and $digit = $ch - 0x30;
            0x61 <= $ch <= 0x7A and $digit = $ch - 0x57;
            0x41 <= $ch <= 0x5A and $digit = $ch - 0x37;
            die "Digit <{substr($str,$ix,1)}> too large for radix $base"
                if $digit >= $base;
            $acc = $acc * $base + $digit;
        }
        ($acc, $places);
    }

    token binint {
        $0=[ <[ 0..1 ]>+ [ _ <[ 0..1 ]>+ ]* ]
        { make from_base(~$0, 2)[0] }
    }

    token octint {
        $0=[ <[ 0..7 ]>+ [ _ <[ 0..7 ]>+ ]* ]
        { make from_base(~$0, 8)[0] }
    }

    token hexint {
        $0=[ <[ 0..9 a..f A..F ]>+ [ _ <[ 0..9 a..f A..F ]>+ ]* ]
        { make from_base(~$0, 16)[0] }
    }

    token decint {
        $0=[ \d+ [ _ \d+ ]* ]
        <?{ make from_base(~$0, 10); True }>
    }

    token integer {
        [
        | 0 [ b '_'? <binint> { make $<binint>.ast }
            | o '_'? <octint> { make $<octint>.ast }
            | x '_'? <hexint> { make $<hexint>.ast }
            | d '_'? <decint> { make $<decint>.ast[0] }
            | <decint> { make $<decint>.ast[0] }
            ]
        | <decint> { make $<decint>.ast[0] }
        ]
    }

    token radint {
        [
        | <integer> { make $<integer>.ast }
        | <?before ':'\d> <rad_number> { make $<rad_number>.ast }
              <?{ $() ~~ Int }>
        ]
    }

    token escale {
        <[Ee]> $0=[<[+\-]>?] <decint>
        { make $0 eq '-' ?? -$<decint>.ast[0] !! $<decint>.ast[0] }
    }

    token dec_number {
        :dba('decimal number')
        [
        | $<coeff> = [              '.' <frac=.decint> ] <escale>?
        | $<coeff> = [<int=.decint> '.' <frac=.decint> ] <escale>?
        | $<coeff> = [<int=.decint>                    ] <escale>
        ]
        {
            my $acc = $<int> ?? $<int>.ast[0] !! 0;
            if $<frac> -> $f {
                my $subn = 10 ** $f.ast[1];
                $acc = FatRat.new($acc * $subn + $f.ast[0], $subn);
            }
            if $<escale> -> $e {
                # forces to Num; XXX not exactly rounded!
                $acc = $acc * 10e0 ** $e.ast;
            }
            make $acc;
        }
    }

    token alnumint {
        [ <[ 0..9 a..z A..Z ]>+ [ _ <[ 0..9 a..z A..Z ]>+ ]* ]
    }

    # XXX: accepts _ in radix (STD does not)
    token rad_number {
        ':' <radix=.decint> [ '\\' \s* ]?      # XXX optional dot here? **
        {}           # don't recurse in lexer
        :s '<' <radixguts($<radix>.ast[0])> '>'
        { make $<radixguts>.ast }
    }
    rule radixguts ($r) {
        :dba('number in radix notation')
        [
        | $<coeff> = [                '.' <frac=.alnumint> ]
        | $<coeff> = [<int=.alnumint> '.' <frac=.alnumint> ]
        | $<coeff> = [<int=.alnumint>                      ]
        ]
        [
            '*' <base=.radint>
               [ '**' <exp=.radint> || { die "Base is missing ** exponent part" } ]
        ]?
        # I don't think we need to parse <circumfix> for the runtime case :)
        {
            my $acc = $<int> ?? from_base(~$<int>, $r)[0] !! 0;
            if $<frac> -> $f {
                my ($fn, $fp) = from_base(~$f, $r);
                my $subn = $r ** $fp;
                $acc = FatRat.new($acc * $subn + $fn, $subn);
            }
            if $<base> -> $b {
                # *not* forcing to Num here
                $acc = $acc * $b.ast ** $<exp>.ast;
            }
            make $acc;
        }
    }

    token number {
        [
        | 'NaN' »      { make NaN }
        | <integer>    { make $<integer>.ast }
        | <dec_number> { make $<dec_number>.ast }
        | <rad_number> { make $<rad_number>.ast }
        | 'Inf' »      { make Inf }
        ]
    }

    token snumber {
        $<sn>=[<[+\-]>?] <.ws> <number>
        { make $<sn> eq '-' ?? -$<number>.ast !! $<number>.ast }
    }

    # <numeric> is used by Str.Numeric conversions such as those done by val()
    # NOTE: allows whitespace for round-tripping
    # XXX: allows radix rationals, which strictly speaking it probably shouldn't
    token numeric {
        [ || $ { make 0 }
          || <re=.snumber>? <.ws>
             [ | <?[+\-]> {}:s <im=.snumber>'\\'?'i'
                 { make Complex.new($<re> ?? $<re>.ast !! 0, $<im>.ast) }
               | '/' {} <.ws> <den=.integer>
                 { die "Parsing $/.orig(), rational parts must be integers"
                       unless $<re>.ast ~~ Int;
                   make FatRat.new($<re>.ast, $<den>.ast) }
               | $ { make $<re>.ast } ] ]
    }

    method str2num ($str, :$fatrat) {
        my ($M) = (token {
            <.ws> [ :lang(Niecza::NumSyntax)
                <numeric> || { die "Cannot parse number: $str" } ] <.ws>
            [ $ || { die "Trailing characters after number at $¢.pos()" } ]
        })(Cursor.cursor_start($str, Any));

        if $fatrat {
            $M<numeric>.ast.FatRat
        } else {
            my $a = $M<numeric>.ast;
            $a ~~ FatRat ?? $a.numerator / $a.denominator !! $a
        }
    }

    method base2num ($str, $base) {
        my ($M) = (token {
            <.ws> [ :lang(Niecza::NumSyntax)
                <radixguts($base)> || {die "Cannot parse :$base: $str" } ] <.ws>
            [ $ || { die "Trailing characters after number at $¢.pos()" } ]
        })(Cursor.cursor_start($str, Any));

        my $a = $M<radixguts>.ast;
        $a ~~ FatRat ?? $a.numerator / $a.denominator !! $a
    }
}

class Niecza::PseudoStr is Str { has $!value }

role Niecza::Dualvar is Niecza::PseudoStr {
    method new($val, Str $str) { Q:CgOp { (dualvar {$val} {self} {$str}) } }
    method Str()  { self // nextsame; Q:CgOp { (box Str (unbox str (@ {self}))) } }
    method gist() { self // nextsame; Q:CgOp { (box Str (unbox str (@ {self}))) } }
    method Numeric() { 0 + self }
    method perl() { "val({(~self).perl})" }
}
class IntStr is Int does Niecza::Dualvar { }
class RatStr is Rat does Niecza::Dualvar { }
class NumStr is Num does Niecza::Dualvar { }
class ComplexStr is Complex does Niecza::Dualvar { }

sub val($str) is pure {
    $_ = Niecza::NumSyntax.str2num($str);
    when Num { return NumStr.new($_, $str) }
    when Rat { return RatStr.new($_, $str) }
    when Int { return IntStr.new($_, $str) }
    when Complex { return ComplexStr.new($_, $str) }
fail:
    return $str;
    CATCH { goto fail; }
}
sub val_nospace($str) is pure {
    return Niecza::NumSyntax.str2num($str);
fail:
    return $str;
    CATCH { goto fail; }
}

# the opposite of Real.base, used for :16($hex_str)
sub unbase(Int:D $base, Cool:D $str) is pure {
    if $str ~~ Array {
        die ":16[...] syntax NYI";
    }
    if $str ~~ Numeric {
        die 'Numbers may not be passed :base(); if you wanted to render the number in the given base, use $number.base($radix); if you want to treat the number as a string, explicitly coerce it first';
    }
    $str := ~$str;
    if $str ~~ m:pos(0) /\s* [ ':' || '0' (<[bdox]>) <?{ ord($0)-97+10 >= $base }> ] / {
        $str.Numeric;
    } else {
        ":{$base}<$str>".Numeric;
    }
}
# }}}
# I/O stuff {{{
sub slurp($path) is unsafe { Q:CgOp { (box Str (slurp (unbox str (@ {$path})))) } }

sub spurt($path,$text) is unsafe { Q:CgOp { (rnull (spurt (unbox str (@ {$path.Str})) (unbox str (@ {$text.Str})))) } }

sub dir($directory = '.', Mu :$test = none('.','..')) is unsafe {
    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 spurt($text) { spurt $.path, $text }

    method combine(*@paths) {
        die "Sorry, paths do not form a monoid." unless @paths;
        my $acc = shift(@paths).IO;
        for @paths { $acc = $acc.append($_) }
        $acc
    }

    method perl() { $.path.perl ~ ".IO" }

    method f() is unsafe { Q:CgOp { (box Bool (path_file_exists (obj_getstr {$!path}))) } }
    method d() is unsafe { Q:CgOp { (box Bool (path_dir_exists (obj_getstr {$!path}))) } }
    method e() is unsafe { Q:CgOp { (box Bool (path_any_exists (obj_getstr {$!path}))) } }
    method r() is unsafe { Q:CgOp { (box Bool (path_eaccess_readable (obj_getstr {$!path}))) } }
    method R() is unsafe { Q:CgOp { (box Bool (path_access_readable (obj_getstr {$!path}))) } }
    method w() is unsafe { Q:CgOp { (box Bool (path_eaccess_writable (obj_getstr {$!path}))) } }
    method W() is unsafe { Q:CgOp { (box Bool (path_access_writable (obj_getstr {$!path}))) } }
    method x() is unsafe { Q:CgOp { (box Bool (path_eaccess_executable (obj_getstr {$!path}))) } }
    method X() is unsafe { Q:CgOp { (box Bool (path_access_executable (obj_getstr {$!path}))) } }
    method o() is unsafe { Q:CgOp { (box Bool (path_eaccess_owned (obj_getstr {$!path}))) } }
    method O() is unsafe { Q:CgOp { (box Bool (path_access_owned (obj_getstr {$!path}))) } }
    method relative($base) { $base.IO.append(self) }
    method append($sub) { Q:CgOp { (box Str (path_combine (obj_getstr {self}) (obj_getstr {$sub}))) }.IO }
    method but-extension($ext) { Q:CgOp { (box Str (path_change_ext (obj_getstr {self}) (obj_getstr {$ext}))) }.IO }
    method realpath() is unsafe { Q:CgOp { (box Str (path_realpath (obj_getstr {self}))) }.IO }
    method modified() is unsafe { Instant.new(val => Q:CgOp { (path_modified (obj_getstr {self})) }) }
    method copy($dest) is unsafe { Q:CgOp { (rnull (path_copy (obj_getstr {self}) (obj_getstr {$dest})))}}
    method chmod($mode) is unsafe { Q:CgOp { (box Int (path_chmod (obj_getstr {self}) (obj_getnum {$mode}))) } }
}

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 = ();
}
# }}}
# Network {{{

class IO::Socket::INET {
    has $!sock;
    has Str $!buffer = '';

    # TODO: This code is horribly broken, especially if a character gets cut by
    # a buffer or packet boundry, or you want to switch from char to binary mode
    # doing it right seems to require some kind of Decoder class

    method recv (Cool $chars = Inf) {
        die('Socket not available') unless $!sock;

        if $!buffer.chars < $chars {
            $!buffer ~= self.read(2048).decode('UTF-8');
        }

        if $!buffer.chars > $chars {
            my $rec  = $!buffer.substr(0, $chars);
            $!buffer = $!buffer.substr($chars);
            $rec
        } else {
            my $rec = $!buffer;
            $!buffer = '';
            $rec;
        }
    }

    method read(IO::Socket::INET:D: Cool $bufsize) {
        die('Socket not available') unless $!sock;
        Q:CgOp { (box Buf (socket_read (unbox socket {$!sock}) (unbox int {$bufsize.Int}))) }
    }

    #method poll(Int $bitmask, $seconds) {
    #    $!sock.poll(
    #        nqp::unbox_i($bitmask), nqp::unbox_i($seconds.floor),
    #        nqp::unbox_i((($seconds - $seconds.floor) * 1000).Int)
    #    );
    #}

    method send (Cool $string) {
        self.write($string.encode('UTF-8'));
    }

    method write(Buf:D $buf) {
        die('Socket not available') unless $!sock;
        Q:CgOp { (rnull (socket_write (unbox socket {$!sock}) (unbox blob {$buf}))) }
    }

    method close () {
        die("Not connected!") unless $!sock;
        Q:CgOp { (rnull (socket_close (unbox socket {$!sock}))) };
        $!sock = Any;
    }

    my module sock {
        # XXX these constants are backend-sensitive.
        constant PF_LOCAL       = 0;
        constant PF_UNIX        = 1;
        constant PF_INET        = 2;
        constant PF_INET6       = 0x17;
        #constant PF_MAX         = 4;
        #constant SOCK_PACKET    = 0;
        constant SOCK_STREAM    = 1;
        constant SOCK_DGRAM     = 2;
        constant SOCK_RAW       = 3;
        constant SOCK_RDM       = 4;
        constant SOCK_SEQPACKET = 5;
        constant SOCK_MAX       = 6;
        constant PROTO_TCP      = 6;
        constant PROTO_UDP      = 17;
    }

    has Str $.host;
    has Int $.port = 80;
    has Str $.localhost;
    has Int $.localport;
    has Bool $.listen;
    has $.family = sock::PF_INET;
    has $.proto = sock::PROTO_TCP;
    has $.type = sock::SOCK_STREAM;
    has Str $.input-line-separator is rw = "\n";
    has Int $.ins = 0;

    my sub v4-split($uri) {
        return $uri.split(':', 2);
    }

    my sub v6-split($uri) {
        my ($host, $port) = ($uri ~~ /^'[' (.+) ']' \: (\d+)$/)[0,1];
        return $host ?? ($host, $port) !! $uri;
    }

    method new (*%args is copy) {
        die "Nothing given for new socket to connect or bind to" unless %args<host> || %args<listen>;

        if %args<host>  {
            my ($host, $port) = %args<family> && %args<family> == sock::PF_INET6()
                ?? v6-split(%args<host>)
                !! v4-split(%args<host>);
            if $port {
                %args<port> //= $port;
                %args<host> = $host;
            }
        }
        if %args<localhost> {
            my ($peer, $port) = %args<family> && %args<family> == sock::PF_INET6()
                ?? v6-split(%args<localhost>)
                !! v4-split(%args<localhost>);
            if $port {
                %args<localport> //= $port;
                %args<localhost> = $peer;
            }
        }

        %args<listen>.=Bool if %args<listen> :exists;

        #TODO: Learn what protocols map to which socket types and then determine which is needed.
        self.bless(*, |%args)!initialize()
    }

    method !initialize() {
        $!sock = Q:CgOp { (box Any (socket_new (unbox int {$.family}) (unbox int {$.type}) (unbox int {$.proto}))) };

        #Quoting perl5's SIO::INET:
        #If Listen is defined then a listen socket is created, else if the socket type,
        #which is derived from the protocol, is SOCK_STREAM then connect() is called.
        if $.listen || $.localhost || $.localport {
            Q:CgOp { (rnull (socket_bind (unbox socket {$!sock}) (unbox str {$.localhost || "0.0.0.0"}) (unbox int {$.localport || 0}))) };
        }

        if $.listen {
            Q:CgOp { (rnull (socket_listen (unbox socket {$!sock}) (unbox int {20}))) };
        }
        elsif $.type == sock::SOCK_STREAM {
            Q:CgOp { (rnull (socket_connect (unbox socket {$!sock}) (unbox str {$.host}) (unbox int {$.port}))) };
        }

        self;
    }

    method get() {
        ++$!ins;
        my $inbuf = '';
        my $irs = $!input-line-separator;
        my $irslen = chars($irs);
        until substr($inbuf, chars($inbuf)-$irslen, $irslen) eq $irs {
            $inbuf ~= (self.recv(1) || return $inbuf);
        }
        substr($inbuf, 0, chars($inbuf)-$irslen);
    }

    method lines() {
        gather { take self.get() };
    }

    method !setsock($ns) {
        $!sock = $ns;
        $!buffer = '';
        self;
    }

    method accept() {
        my $new_sock := self.WHAT.bless(*, :$!family, :$!proto, :$!type);
        $new_sock!setsock( Q:CgOp { (box Any (socket_accept (unbox socket {$!sock}))) } );
    }

    #method remote_address() {
    #    return nqp::p6box_s(nqp::getattr(self, $?CLASS, '$!sock').remote_address());
    #}

    #method local_address() {
    #    return nqp::p6box_s(nqp::getattr(self, $?CLASS, '$!sock').local_address());
    #}
}
# }}}

{YOU_ARE_HERE}