SAFE.setting

# vim: ft=perl6 fdm=marker
my module SAFE;

# Fundamental types {{{
my class Mu {
    # rawcall to avoid putting a rw binding on self... TODO
    method defined is rawcall {
        Q:CgOp { (box Bool (obj_is_defined (@ (pos 0)))) }
    }
    method head() { @(self).head }
    method Bool() { self.defined }
    method Str() {
        my $tn := Q:CgOp { (box Str (obj_typename (@ {self}))) };
        if self.defined {
            $tn ~ "()<instance>"
        } else {
            $tn ~ "()"
        }
    }
    method so() { self.Bool }
    method not() { ! self.Bool }
    method RAWCREATE is rawcall { Q:CgOp {
        (withtypes i int max int obj clr:DynObject
          [l max (getfield Length (getfield pos (callframe)))]
          [l i (int 1)]
          [l obj (rawnew clr:DynObject (getfield klass (cast clr:DynObject
                  (@ (pos 0)))))]
          [whileloop 0 0 (< (l i) (l max)) (prog
              [setslot
                (unbox str (@ (pos (l i)))) (l obj)
                (nsw (@ (pos (+ (l i) (int 1)))))]
              [l i (+ (l i) (int 2))])]
          [ns (l obj)])
    } }
    method bless($obj) { Q:CgOp {
        (prog
          [setfield klass (cast clr:DynObject (@ {$obj}))
            (getfield klass (cast clr:DynObject (@ {self})))]
          {$obj})
    } }
    method CREATE() { Q:CgOp {
        (rawscall Kernel.DefaultNew (@ (l self))) } }
    method new() { Q:CgOp { (rawscall Kernel.DefaultNew (@ {self})) } }
}

my class Any is Mu {
    method at-pos($ix) {
        ($ix == 0) ?? self !! die("Invalid index on non-list")
    }
    method flat() { (self,).flat }

    method ACCEPTS($t) { self === $t }
    method !butWHENCE($cr) {
        Q:CgOp { (newgeneralvar (bool 1) (bool 0) (@ {$cr}) (@ {self})) }
    }
}

my class Cool {
    method grep($sm) {
        my $itp = @(self).clone;
        gather while $itp {
            my $r = $itp.shift;
            take $r if $r ~~ $sm;
        }
    }
    method map($func) {
        my $itp = @(self).clone;
        gather while $itp {
            my $r = $itp.shift;
            take $func($r);
        }
    }
    method for($func) {
        my $itp = @(self).clone;
        while $itp {
            my $r = $itp.shift;
            $func($r);
        }
    }

    method say() { self.Str.say }
    method chars() { self.Str.chars }
    method substr($x,$y) { self.Str.substr($x,$y) }

    method at-pos($i) { self.flat.at-pos($i) }
    method elems() { self.flat.elems }
    method iterator() { self.flat.iterator }
    method join($sep) { self.flat.join($sep) }
}
# }}}
# Scalar types {{{
my class Num is Cool {
    has $!value;
    method Str () { Q:CgOp {
        (box Str (num_to_string (unbox num (@ {self}))))
    } }
    method Bool() { Q:CgOp {
        (box Bool (compare != (double 0) (unbox num (@ {self}))))
    } }
    method Numeric() { self }
    method ACCEPTS($t) { self == $t }
}

my class Str is Cool {
    has $!value;
    method Str () { self }
    method ACCEPTS($t) { self eq $t }
    method chars() { Q:CgOp {
        (box Num (cast num (str_length (unbox str (@ (l self))))))
    } }
    method say() { Q:CgOp {
        (prog [rawscall Console.WriteLine
                (unbox str (@ {self}))]
              [box Bool (bool 1)]
        )
    } }
    method substr($from, $len) { Q:CgOp {
        (box Str (rawcall [unbox str (@ {self})] Substring
                    [cast int (unbox num (@ {$from}))]
                    [cast int (unbox num (@ {$len}))]))
    } }
}

my class Scalar {
    has $!value;
}

my class Sub {
    has $!outer;
    has $!info;

    # Should be for Block, not Sub
    method ACCEPTS($t) { (self)($t) }
}

my class ClassHOW {
    has $!value;
    method isa($obj, $type) { Q:CgOp {
        (box Bool (obj_isa (@ {$obj}) (obj_llhow (@ {$type}))))
    } }
    method does($obj, $role) { self.isa($obj, $role) } #no roles yet
}

my class EnumType is Cool { }
my class Bool is EnumType {
    has $!value;
    method Str() { self ?? "Bool::True" !! "Bool::False" }
    method Bool() { self }
    method ACCEPTS($) { self }
    method Numeric() { self ?? 1 !! 0 }
    our constant True  = Q:CgOp { (box Bool (bool 1)) };
    our constant False = Q:CgOp { (box Bool (bool 0)) };
}
# TODO: import
constant True  = Q:CgOp { (box Bool (bool 1)) };
constant False = Q:CgOp { (box Bool (bool 0)) };
# }}}
# Fundamental scalar operators {{{
# taking a slurpy is wrong for this due to flattening.  I'm not sure what is
# right, maybe **@foo
sub infix:<~> is rawcall { Q:CgOp {
    (letn buf (rawnew clr:System.Text.StringBuilder)
          i   (int 0)
          max (getfield Length (getfield pos (callframe)))
      [whileloop 0 0 (< (l i) (l max)) (prog
          [rawcall (l buf) Append
            (unbox str (@ (methodcall (pos (l i)) Str)))]
          [l i (+ (l i) (int 1))])]
      [box Str (rawcall (l buf) ToString)])
} }

sub infix:<+>($l,$r) { Q:CgOp {
    (box Num (+ (unbox num (@ {$l})) (unbox num (@ {$r}))))
} }

sub infix:<->($l,$r) { Q:CgOp {
    (box Num (- (unbox num (@ {$l})) (unbox num (@ {$r}))))
} }

sub infix:<*>($l,$r) { Q:CgOp {
    (box Num (* (unbox num (@ {$l})) (unbox num (@ {$r}))))
} }

sub infix:</>($l,$r) { Q:CgOp {
    (box Num (/ (unbox num (@ {$l})) (unbox num (@ {$r}))))
} }

sub infix:<< < >>($l,$r) { Q:CgOp {
    (box Bool (< (unbox num (@ {$l})) (unbox num (@ {$r}))))
} }

sub infix:<< > >>($l,$r) { Q:CgOp {
    (box Bool (> (unbox num (@ {$l})) (unbox num (@ {$r}))))
} }

sub infix:<< <= >>($l,$r) { Q:CgOp {
    (box Bool (<= (unbox num (@ {$l})) (unbox num (@ {$r}))))
} }

sub infix:<< >= >>($l,$r) { Q:CgOp {
    (box Bool (>= (unbox num (@ {$l})) (unbox num (@ {$r}))))
} }

sub infix:<< == >>($l,$r) { Q:CgOp {
    (box Bool (== (unbox num (@ {$l})) (unbox num (@ {$r}))))
} }

sub infix:<< != >>($l,$r) { Q:CgOp {
    (box Bool (!= (unbox num (@ {$l})) (unbox num (@ {$r}))))
} }

sub warn($str) { Q:CgOp {
    (prog [rawscall Console.Error.WriteLine
            (unbox str (@ {$str.Str}))]
          [box Bool (bool 1)]
    )
} }

sub say($obj) { ($obj ~~ Cool) ?? $obj.say !! $obj.Str.say }

sub exit() { Q:CgOp {
    (prog [rawscall System.Environment.Exit (int 0) ]
          [null var]
    )
} }

sub infix:<=> is rawcall { Q:CgOp { (prog [assign (pos 0) (pos 1)] (pos 0)) } }

# Buglet in STD: standard infix operators look custom inside the setting, and
# forget their precedence.
sub prefix:<-->($v) { $v = ($v - 1); $v }
sub prefix:<++>($v) { $v = ($v + 1); $v }
sub postfix:<-->($v) { my $old = $v; $v = ($v - 1); $old }
sub postfix:<++>($v) { my $old = $v; $v = ($v + 1); $old }

sub prefix:<~>($v) { $v.Str } # should be Stringy
sub prefix:<?>($v) { $v.Bool }
sub prefix:<->($v) { 0 - $v }
sub prefix:<+>($x) { $x.Numeric }

sub prefix:<!>($v) { $v ?? False !! True }

sub infix:<eq>($l,$r) { Q:CgOp {
    (box Bool (compare == (unbox str (@ {$l.Str}))
      (unbox str (@ {$r.Str}))))
} }
sub infix:<ne>($l,$r) { Q:CgOp {
    (box Bool (compare != (unbox str (@ {$l.Str}))
      (unbox str (@ {$r.Str}))))
} }
# this one is horribly wrong and only handles the ref eq case.
sub infix:<===>($l,$r) { Q:CgOp {
    (box Bool (compare == (@ {$l}) (@ {$r})))
} }

sub infix:<~~>($t,$m) { ($m.defined) ?? ($m.ACCEPTS($t)) !! ($t.^does($m)) }
# }}}
# 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.
# Seq: mutable list of boxes which are taken to be read-only scalars. The .Seq
# coercion makes the elements of a List read-only and maybe fetches them too.
# Array: mutable list of read-write scalar boxes

sub unitem is rawcall {
    Q:CgOp { (newrwlistvar (@ (pos 0))) }
}

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

sub flat(*@x) { @x }

my class Whatever { }

my class EMPTY { }

my class List { ... }
my class Seq { ... }
my class Array { ... }

my class Parcel is Cool {
    has $!value;
    # $!value -> Variable[]

    method flat() { List.SETUP(True, self) }
    method list() { List.SETUP(False, self) }

    method elems() { Q:CgOp {
        (box Num (cast num (fvarlist_length (unbox fvarlist (@ {self})))))
    } }

    method iterator() {
        my class ParcelIterator is Iterator {
            has $.reify;
        }
        ParcelIterator.RAWCREATE("reify", self);
    }
}

# Maybe this should be a constant, but constants are currently forced to
# scalar-nature (TODO)
sub Nil is rawcall { Q:CgOp { (newrwlistvar (@ (box Parcel (fvarlist_new)))) } }

my class List is Cool {
    has @!items;
    has @!rest;
    has $!flat;
    method flat() {
        unitem(Q:CgOp { (box Bool (getslot flat bool (@ {self}))) }
            ?? self !! self.SETUP(True, (&infix:<,>(self.iterator))));
    }
    method list() { unitem(self) }

    method clone() { Q:CgOp {
        (letn selfo (@ {self})
              new (rawnew clr:DynObject (obj_llhow (l selfo)))
          (setslot flat (l new) (getslot flat bool (l selfo)))
          (setslot items (l new) (rawnew vvarlist
              (getslot items vvarlist (l selfo))))
          (setslot rest (l new) (rawnew vvarlist
              (getslot rest vvarlist (l selfo))))
          (newrwlistvar (l new)))
    } }

    method SETUP($flat, $parcel) { Q:CgOp {
        (letn new (rawnew clr:DynObject (obj_llhow (@ {self})))
          (setslot flat (l new) (unbox bool (@ {$flat.Bool})))
          (setslot rest (l new) (vvarlist_from_fvarlist
              (unbox fvarlist (@ {$parcel}))))
          (setslot items (l new) (vvarlist_new_empty))
          (newrwlistvar (l new)))
    } }

    method Seq() {
        Seq.SETUP(True, (&infix:<,>(self.iterator)));
    }

    #| Takes an object and applies whatever semantics the List subclass
    #| needs to apply on stuff out of the iterator stack
    method _elem is rawcall { Q:CgOp { (pos 1) } }

    sub count-items($self) { Q:CgOp {
        (box Num (cast num (vvarlist_count (getslot items vvarlist (@ {$self})))))
    } }

    sub shift-item($self) { Q:CgOp {
        (vvarlist_shift (getslot items vvarlist (@ {$self})))
    } }

    method !item-at-pos($ix) { Q:CgOp {
        (vvarlist_item (cast int (unbox num (@ {$ix}))) (getslot items vvarlist (@ {self})))
    } }

    sub pop-item($self) { Q:CgOp {
        (vvarlist_pop (getslot items vvarlist (@ {$self})))
    } }

    sub push-iterator is rawcall { Q:CgOp {
        (rnull (vvarlist_push (getslot rest vvarlist (@ (pos 0))) (pos 1)))
    } }

    sub push-item is rawcall { Q:CgOp {
        (rnull (vvarlist_push (getslot items vvarlist (@ (pos 0))) (pos 1)))
    } }

    method !fill($nr) { Q:CgOp {
        (letn  nr    (cast int (unbox num (@ {$nr})))
               items (getslot items vvarlist (@ {self}))
               rest  (getslot rest vvarlist (@ {self}))
               flat  (getslot flat bool (@ {self}))
               v     (null var)
               ItMo  (obj_llhow (@ {Iterator}))
          (whileloop 0 0
            (ternary (< (vvarlist_count (l items)) (l nr))
              (!= (vvarlist_count (l rest)) (i 0)) (b 0))
            (prog
              (l v (vvarlist_shift (l rest)))
              (ternary (ternary (l flat) (getfield islist (l v)) (b 0))
                (vvarlist_unshift (l rest) (methodcall (l v) iterator))
                (ternary (obj_isa (@ (l v)) (l ItMo))
                  (vvarlist_unshiftn (l rest) (unbox fvarlist
                      (@ (methodcall (l v) reify))))
                  (vvarlist_push (l items) (methodcall {self} _elem (l v)))))))
          (box Bool (>= (vvarlist_count (l items)) (l nr))))
    } }

    method Bool() { self!fill(1) }
    method shift() {
        self!fill(1);
        shift-item(self);
    }

    method eager() {
        self!fill(1_000_000_000);
        self;
    }

    method head { self!fill(1) ?? self!item-at-pos(0) !! Any }

    method elems() { self!fill(1000_000_000); count-items(self); }
    method Numeric () { self.elems }

    method at-pos($i) {
        self!fill($i + 1);
        self!item-at-pos($i);
    }

    method iterator() {
        my class ListIterator is Iterator {
            has $!list;
            has $!reify;
            method reify() {
                $!reify // ($!reify = (
                    $!list ??
                        ($!list.shift, ListIterator.RAWCREATE("list", $!list,
                            "reify", Any)) !!
                        &infix:<,>()));
            }
        }
        my $itp = self.clone;
        ListIterator.RAWCREATE("list", $itp, "reify", Any);
    }

    method join($sep) {
        my $t;
        for self.flat -> $x {
            $t = ($t.defined ?? ($t ~ ($sep ~ $x)) !! $x);
        }
        $t // '';
    }

    method Str() { self.join(" ") }

    method push(*@items) {
        push-iterator(self, @items.Seq.eager.iterator)
    }
    method pop() {
        self.eager;
        pop-item(self);
    }
}

# exactly like List, but flattens, and with "is copy" semantics on stuff
my class Seq is List {
    method _elem($x) { my $y = $x; $y }
    method Seq { self }
}

my class Array is List {
    method new() {
        Array.SETUP(True, &infix:<,>())
    }

    method LISTSTORE(*@in) {
        # fetch everything NOW in case self is mentioned
        my $inn := @in.Seq.eager;

        Q:CgOp { (rnull
            (setslot items (@ {self}) (getslot items vvarlist (@ {$inn}))))
        };
        unitem(self);
    }

    method !extend is rawcall {
        Q:CgOp {
            (letn i (getslot items vvarlist (@ (pos 0)))
                  ct (- (cast int (unbox num (@ (pos 1))))
                        (vvarlist_count (l i)))
              (ternary (>= (l ct) (int 0)) [prog]
                [sink [die "Autovivification collision"]])
              (whileloop 0 0 (!= (l ct) (int 0))
                (prog
                  (l ct (- (l ct) (int 1)))
                  (vvarlist_push (l i) (newrwscalar (@ {Any})))))
              (vvarlist_push (l i) (pos 2))
              (null var))
        };
    }

    method at-pos($ix) {
        self!List::fill($ix+1)
            ?? self!List::item-at-pos($ix)
            !! Any!Any::butWHENCE(sub () is rawcall {
                self!extend($ix, Q:CgOp { (pos 0) });
            });
    }
}

my class Hash {
    has $!value;
    method new() { Q:CgOp { (box Hash (varhash_new)) } }
    method !extend is rawcall {
        Q:CgOp {
            (letn d [unbox varhash (@ (pos 0))]
                  k [unbox str (@ (methodcall (pos 1) Str))]
              [ternary (varhash_contains_key (l d) (l k))
                (sink (die "Autovivification collision"))
                (prog)]
              [varhash_setindex (l k) (l d) (pos 2)]
              [null var])
        };
    }

    # TODO: We need something like pir:: notation for this to not suck
    method at-key($key) {
        Q:CgOp {
            (box Bool (varhash_contains_key [unbox varhash (@ {self})]
                [unbox str (@ {$key.Str})]))
        }
            ?? Q:CgOp {
                (varhash_getindex [unbox str (@ {$key.Str})]
                  [unbox varhash (@ {self})])
            } !! Any!Any::butWHENCE({ self!extend($key, Q:CgOp { (pos 0) }) });
    }
}

my class Enum is Cool {
    has $.key;
    has $.value;

    method kv() {
        ($.key, $.value);
    }

    method pairs() {
        self.flat;
    }
}

my class Pair is Enum {
}
# }}}
# List utilities {{{
sub postcircumfix:<[ ]> is rawcall {
    my $index ::= Q:CgOp { (pos 1) };

    (Q:CgOp { (pos 0) }).defined
        ?? (Q:CgOp { (pos 0) }).at-pos($index)
        !! Any!Any::butWHENCE(sub () is rawcall {
            my $ar := Q:CgOp { (getindex (int 0) (getfield pos
                                 (getfield outer (callframe)))) };
            $ar.defined && die("Autovivification collision");
            $ar = Array.new;
            $ar!Array::extend($index, Q:CgOp { (pos 0) });
        });
}

sub postcircumfix:<{ }> is rawcall {
    my $key ::= Q:CgOp { (pos 1) };

    (Q:CgOp { (pos 0) }).defined
        ?? (Q:CgOp { (pos 0) }).at-key($key)
        !! Any!Any::butWHENCE(sub () is rawcall {
            my $ar := Q:CgOp { (getindex (int 0) (getfield pos
                                 (getfield outer (callframe)))) };
            $ar.defined && die("Autovivification collision");
            $ar = Hash.new;
            $ar!Hash::extend($key, Q:CgOp { (pos 0) });
        });
}

my class GatherIterator is Iterator {
    has $!frame;
    has $!reify;

    method reify() {
        my $*nextframe;
        $!reify // ($!reify = (
            Q:CgOp {
                (letn getv (rawsccall Kernel.CoTake (cast clr:Frame
                    (@ {$!frame})))
                  (box Parcel (ternary (== (@ {EMPTY}) (@ (l getv)))
                    (rawnewarr var)
                    (rawnewarr var
                      (l getv)
                      {GatherIterator.RAWCREATE("frame", $*nextframe, "reify", Any)}))))
            }));
    }
}

sub _gather($fr) {
    List.SETUP(True, (&infix:<,>(GatherIterator.RAWCREATE("frame", $fr,
        "reify", Any))));
}

sub take($p) { # should be \|$p
    Q:CgOp { (rawsccall Kernel.Take (l $p)) }
}

sub infix:<< => >>($k, $v) { Pair.RAWCREATE("key", $k, "value", $v) }

sub infix:<,> is rawcall {
    Q:CgOp { (newrwlistvar (@ (box Parcel (getfield pos (callframe))))) };
}
# }}}
# Flow inspection and control {{{
my class CallFrame {
    method caller() { Q:CgOp {
        (letn c (getfield caller (cast clr:Frame (@ {self})))
          (ternary
            (!= (letvar c) (null clr:Frame))
            (ns (letvar c))
            {Any}))
    } }
    method outer() { Q:CgOp {
        (letn c (getfield outer (cast clr:Frame (@ {self})))
          (ternary
            (!= (letvar c) (null clr:Frame))
            (ns (letvar c))
            {Any}))
    } }

    method file() { Q:CgOp { (box Str (rawcall
        (cast clr:Frame (@ (l self))) ExecutingFile)) } }
    method line() { Q:CgOp { (box Num (cast num (rawcall
        (cast clr:Frame (@ (l self))) ExecutingLine))) } }

    method hints($var) { Q:CgOp { (rawcall (cast clr:Frame (@ (l self)))
        LexicalFind (unbox str (@ (l $var)))) } }
}

sub caller { Q:CgOp { (ns (getfield caller (getfield caller (callframe)))) } }
sub callframe { Q:CgOp { (ns (getfield caller (callframe))) } }

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

# XXX multi dispatch
sub next {
    Q:CgOp { (rawsccall Kernel.SearchForHandler (int 1) (null clr:Frame) (int -1) (null str) (null var)) }
}
sub last {
    Q:CgOp { (rawsccall Kernel.SearchForHandler (int 2) (null clr:Frame) (int -1) (null str) (null var)) }
}
sub redo {
    Q:CgOp { (rawsccall Kernel.SearchForHandler (int 3) (null clr:Frame) (int -1) (null str) (null var)) }
}
sub return is rawcall {
    Q:CgOp { (rawsccall Kernel.SearchForHandler (int 4) (null clr:Frame) (int -1) (null str) (pos 0)) }
}

sub assignop($fn) {
    anon sub ANON is rawcall {
        Q:CgOp { (pos 0) } = $fn(Q:CgOp { (pos 0) }, Q:CgOp { (pos 1) })
    }
}
# }}}
# Regular expression support {{{
my class Cursor {
    method new($str) { Q:CgOp { (ns (rawnew clr:Cursor
        (@ {self}) (unbox str (@ {$str})))) } }
    method pos { Q:CgOp { (box Num (cast num (getfield pos
        (cast clr:Cursor (@ {self}))))) } }
    method cursor($np) { Q:CgOp { (ns (rawcall
        (cast clr:Cursor (@ {self})) At
          (cast int (unbox num (@ {$np}))))) } }
    method orig { Q:CgOp {
        (box Str (getfield backing (cast clr:Cursor (@ {self})))) } }
    method ws() { Q:CgOp { (rawcall (cast clr:Cursor (@ {self})) SimpleWS) } }
    method at-key($k) { Q:CgOp {
        (rawcall (cast clr:Cursor (@ {self})) GetKey (unbox str (@ {$k.Str})))
    } }
    method at-pos($i) { self.at-key($i) }
}

my class Match {
    method at-key($k) { Q:CgOp {
        (rawcall (cast clr:Cursor (@ {self})) GetKey (unbox str (@ {$k.Str})))
    } }
    method at-pos($i) { self.at-key($i) }
    method new($) { die "Match.new NYI" }
    method from { Q:CgOp { (box Num (cast num (getfield from
        (cast clr:Cursor (@ {self}))))) } }
    method to { Q:CgOp { (box Num (cast num (getfield pos
        (cast clr:Cursor (@ {self}))))) } }
    method orig { Q:CgOp {
        (box Str (getfield backing (cast clr:Cursor (@ {self})))) } }
    method chars { $.defined ?? $.to - $.from !! 0 }
    method Str { $.defined ?? $.orig.substr($.from, $.chars) !! "" }
}

my class Regex is Sub {
    method ACCEPTS($str) {
        my $i = 0;
        my $mat;
        my $C = Cursor.new($str);
        while !$mat && ($i <= $str.chars) {
            $mat = (self)($C.cursor($i++));
        }
        $mat.head;
    }
}

my class Grammar is Cursor {
    method parse($text) {
        my @results := self.new($text).TOP\
            .grep({ $_.to == $text.chars });
        @results ?? @results.shift !! Any; # TODO List.at-pos
    }
}
# }}}

{YOU_ARE_HERE}