CORE.setting

# vim: ft=perl6

my module CORE;

# We have to do this directly due to the circularity saw.  Same
# reason forces uncontainerized .NET values.
#
# class ClassHOW {
#     has DynMetaObject $.meta-object;
# }
#
# Due to concerns of screwing up composition, adding new superclasses, roles,
# or attributes in an augment is not allowed at this time.  Methods only.
#
# to create a class:
#     BEGIN my $Foo_HOW ::= ClassHOW.new("Foo");
#     BEGIN my $Foo;
#     BEGIN {
#         $Foo_HOW.add-super(...);
#         $Foo_HOW.add-role(...);
#         $Foo_HOW.add-method("bar", anon method bar { ... });
#         $Foo_HOW.compose;
#         $Foo ::= $Foo_HOW.create-protoobject;
#     }
#
# to augment:
#     BEGIN { Foo.HOW.add-method("baz", anon method baz { ... }); }
my class ClassHOW { ... }

PRE-INIT {
    # ClassHOW.new($name) --> meta class instance
    sub new { Q:CgOp {
        (withtypes $mo DynMetaObject $self DynObject
          [l $mo   (rawnew DynMetaObject (unbox String (@ (pos 1))))]
          [l $self (rawnew DynObject (getfield klass
            (cast DynObject (@ (pos 0)))))]

          [setfield how (l $mo) (l $self)]
          [setindex meta-object (getfield slots (l $self))
            (nsw (rawnew CLRImportObject (l $mo)))]

          [ns (l $self)])
    } }

    # $how.add-super($p)
    sub add-super { Q:CgOp { (prog
        [rawcall
          (getfield superclasses (unwrap DynMetaObject
            (getattr meta-object (@ (pos 0))))) Add
          (unwrap DynMetaObject (getattr meta-object (how (@ (pos 1)))))]
        [null Variable])
    } }

    # $how.add-method($name, $sub)
    sub add-method { Q:CgOp {
        (prog
          [setindex (unbox String (@ (pos 1)))
            (getfield local (unwrap DynMetaObject (getattr meta-object
              (@ (pos 0)))))
            (@ (pos 2))]

          [null Variable])
    } }

    # $how.add-attribute($name)
    sub add-attribute { Q:CgOp {
        (prog
          [setindex (unbox String (@ (pos 1)))
            (getfield local_attr (unwrap DynMetaObject (getattr meta-object
              (@ (pos 0)))))
            (null IP6)]

          [null Variable])
    } }

    # $how.create-protoobject()
    sub create-protoobject { Q:CgOp {
        (withtypes $p DynObject $mo DynMetaObject
          [l $mo (unwrap DynMetaObject (getattr meta-object (@ (pos 0))))]
          [l $p (rawnew DynObject (l $mo))]

          [rawcall (l $mo) BuildC3MRO]

          [setfield slots (l $p) (null Dictionary<string,object>)]
          [setfield typeObject (l $mo) (l $p)]

          [newscalar (l $p)])
    } }

    sub compose { Q:CgOp { (null Variable) } }

    Q:CgOp {
        (withtypes $chmo DynMetaObject $chch Variable
          [l $chmo (rawnew DynMetaObject (clr_string "ClassHOW"))]
          [l $chch (ns (rawnew DynObject (l $chmo)))]

          [setfield how (l $chmo) (@ (l $chch))]
          [setindex meta-object (getfield slots (cast DynObject (@ (l $chch))))
            (w (l $chmo))]

          [sink (subcall (@ (l &add-method)) (l $chch)
            (string_var "new") (l &new))]
          [sink (subcall (@ (l &add-method)) (l $chch) 
            (string_var "add-method") (l &add-method))]
          [sink (subcall (@ (l &add-method)) (l $chch)
            (string_var "add-attribute") (l &add-attribute))]
          [sink (subcall (@ (l &add-method)) (l $chch)
            (string_var "add-super") (l &add-super))]
          [sink (subcall (@ (l &add-method)) (l $chch)
            (string_var "compose") (l &compose))]
          [sink (subcall (@ (l &add-method)) (l $chch)
            (string_var "create-protoobject") (l &create-protoobject))]

          [l ClassHOW (subcall (@ (l &create-protoobject)) (l $chch))]

          [null Variable])
    }
}

# cannot be a normal class - it has no parents
my class Mu { ... }
my class Any { ... }
my class Cool { ... }
# these are really defined in the kernel
my class Scalar { ... }
my class Sub { ... }
PRE-INIT {
    # (DynMetaObject $dmo, ClassHOW $super --> ClassHOW)
    sub wrap-dpmo { Q:CgOp {
        (withtypes $ch Variable $dm DynMetaObject
          [l $ch (methodcall (l ClassHOW) new (string_var ""))]
          [l $dm (unwrap DynMetaObject (@ (pos 0)))]

          [assign (varattr meta-object (@ (l $ch))) (w (l $dm))]
          [setfield how (l $dm) (@ (l $ch))]
          [sink (methodcall (l $ch) add-super (pos 1))]
          [l $ch])
    } }

Q:CgOp {
    (withtypes !plist List<DynMetaObject> Mu!HOW Variable Any!HOW Variable
        Cool!HOW Variable Scalar!HOW Variable Sub!HOW Variable

      [l Mu!HOW (methodcall (l ClassHOW) new (string_var Mu))]
      [l Mu (methodcall (l Mu!HOW) create-protoobject)]

      [l Any!HOW (methodcall (l ClassHOW) new (string_var Any))]
      [sink (methodcall (l Any!HOW) add-super (l Mu))]
      [l Any (methodcall (l Any!HOW) create-protoobject)]

      [rawsset Kernel.AnyP (@ (l Any))]

      [l Cool!HOW (methodcall (l ClassHOW) new (string_var Cool))]
      [sink (methodcall (l Cool!HOW) add-super (l Any))]
      [l Cool (methodcall (l Cool!HOW) create-protoobject)]

      [sink (methodcall (ns (how (@ (l ClassHOW)))) add-super (l Any))]
      [rawcall (getfield klass (cast DynObject (@ (l ClassHOW)))) BuildC3MRO]

      [l Sub!HOW (subcall (@ (l &wrap-dpmo))
        (w (rawsget Kernel.SubMO)) (l Any))]
      [l Sub (methodcall (l Sub!HOW) create-protoobject)]

      [l Scalar!HOW (subcall (@ (l &wrap-dpmo))
        (w (rawsget Kernel.ScalarMO)) (l Any))]
      [l Scalar (methodcall (l Scalar!HOW) create-protoobject)]

      [null Variable])
} }

my class Junction is Mu { }
my class Num is Cool {
    method Str () { Q:CgOp {
        (box Str (rawcall (unbox Double (fetch (scopedlex self))) ToString))
    } }
    method Bool() { Q:CgOp {
        (box Bool (compare != (double 0)
                    (unbox Double (fetch (scopedlex self)))))
    } }
    method ACCEPTS($t) { self == $t }
}
my class Str is Cool {
    method Str () { self }
    method ACCEPTS($t) { self eq $t }
    method chars() { Q:CgOp {
        (box Num (cast Double (getfield Length (unbox String (@ (l self))))))
    } }
    method say() { Q:CgOp {
        (prog [rawscall Console.WriteLine
                (unbox String (fetch (l self)))]
              [box Bool (bool 1)]
        )
    } }
    method substr($from, $len) { Q:CgOp {
        (box Str (rawcall [unbox String (@ (l self))] Substring
                    [cast Int32 (unbox Double (@ (l $from)))]
                    [cast Int32 (unbox Double (@ (l $len)))]))
    } }
}
PRE-INIT { Q:CgOp { (prog [rawsset Kernel.StrP (@ (l Str))] [null Variable]) } }
my class Blob { }
my class Char { }
my class CharLingua { }
my class AnyChar { }
my class Codepoint { }
my class Grapheme { }
my class StrPos { }
my class StrLen { }
my class Rat { }
my class FatRat { }
my class Complex { }
my class Int { }
my class UInt { }
my class Bit { }
my class Instant { }
my class Duration { }
my class Enum is Cool { }
my class Bool is Enum {
    method Str() { self ?? "Bool::True" !! "Bool::False" }
    method Bool() { self }
    method ACCEPTS($) { self }
}
constant True  = Q:CgOp { (box Bool (bool 1)) };
constant False = Q:CgOp { (box Bool (bool 0)) };

# taking a slurpy is wrong for this due to flattening.  I'm not sure what is
# right, maybe **@foo
sub infix:<~> { Q:CgOp {
    (letn buf (rawnew 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 String (@ (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 (arith + (unbox Double (fetch (scopedlex $l)))
                      (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:<->($l,$r) { Q:CgOp {
    (box Num (arith - (unbox Double (fetch (scopedlex $l)))
                      (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:<*>($l,$r) { Q:CgOp {
    (box Num (arith * (unbox Double (fetch (scopedlex $l)))
                      (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:</>($l,$r) { Q:CgOp {
    (box Num (arith / (unbox Double (fetch (scopedlex $l)))
                      (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:<< < >>($l,$r) { Q:CgOp {
    (box Bool (compare < (unbox Double (fetch (scopedlex $l)))
                         (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:<< > >>($l,$r) { Q:CgOp {
    (box Bool (compare > (unbox Double (fetch (scopedlex $l)))
                         (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:<< <= >>($l,$r) { Q:CgOp {
    (box Bool (compare <= (unbox Double (fetch (scopedlex $l)))
                          (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:<< >= >>($l,$r) { Q:CgOp {
    (box Bool (compare >= (unbox Double (fetch (scopedlex $l)))
                          (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:<< == >>($l,$r) { Q:CgOp {
    (box Bool (compare == (unbox Double (fetch (scopedlex $l)))
                          (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:<< != >>($l,$r) { Q:CgOp {
    (box Bool (compare != (unbox Double (fetch (scopedlex $l)))
                          (unbox Double (fetch (scopedlex $r)))))
} }

sub warn($str) { Q:CgOp {
    (prog [rawscall Console.Error.WriteLine
            (unbox String (fetch (methodcall (scopedlex $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 Variable]
    )
} }

sub infix:<=> { 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 }

# actually a macro
# sub infix:<:=>($l,$r) { ... }

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

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

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

sub infix:<~~>($t,$m) { ($m.defined) ?? ($m.ACCEPTS($t)) !! ($t.^does($m)) }

# XXX: We can't use augment syntax because we don't have use working, so
# no MONKEY_TYPING.

PRE-INIT {
    Mu.HOW.add-method("defined", anon method defined() {
            Q:CgOp { (box Bool (!= (null Dictionary<string,object>)
                (getfield slots (cast DynObject (@ (l self)))))) }
        });
    Mu.HOW.add-method("Bool", anon method Bool() { self.defined });
    Mu.HOW.add-method("Str", anon method Str() {
            my $tn := Q:CgOp {
                (box Str (getfield name (getfield klass
                    (cast DynObject (fetch (scopedlex self))))))
            };
            if self.defined {
                $tn ~ "()<instance>"
            } else {
                $tn ~ "()"
            }
        });
    Mu.HOW.add-method("notdef", anon method notdef() { ! self.defined });
    Mu.HOW.add-method("so", anon method so() { self.Bool });
    Mu.HOW.add-method("not", anon method not() { ! self.Bool });
    Mu.HOW.add-method("RAWCREATE", anon method RAWCREATE { Q:CgOp {
            (withtypes i Int32 max Int32 obj DynObject
              [l max (getfield Length (getfield pos (callframe)))]
              [l i (int 1)]
              [l obj (rawnew DynObject (getfield klass (cast DynObject
                      (@ (pos 0)))))]
              [whileloop 0 0 (< (l i) (l max)) (prog
                  [setindex
                    (unbox String (@ (pos (l i))))
                    (getfield slots (l obj))
                    (nsw (@ (pos (+ (l i) (int 1)))))]
                  [l i (+ (l i) (int 2))])]
              [ns (l obj)])
        } });
    Mu.HOW.add-method("bless", anon method bless($obj) { Q:CgOp {
            (prog
              [setfield klass (cast DynObject (@ (l $obj)))
                (getfield klass (cast DynObject (@ (l self))))]
              [l $obj])
        } });
    Mu.HOW.add-method("CREATE", anon method CREATE() { Q:CgOp {
            (rawscall Kernel.DefaultNew (@ (l self))) } });
    Mu.HOW.add-method("new", anon method new() { Q:CgOp {
            (rawscall Kernel.DefaultNew (@ (l self))) } });

    Any.HOW.add-method("flat", anon method flat() { self, });

    Any.HOW.add-method("ACCEPTS", anon method ACCEPTS($t) { self === $t });

    # Should be for Block, not Sub
    Sub.HOW.add-method("ACCEPTS", anon method ACCEPTS($t) { (self)($t) });

    ClassHOW.HOW.add-method("isa", anon method isa($obj, $type) { Q:CgOp {
            (box Bool (rawcall (getfield klass (cast DynObject (@ (l $obj))))
              HasMRO (getfield klass (cast DynObject (@ (l $type))))))
        } });
    ClassHOW.HOW.add-method("does",
        anon method does($obj, $role) { self.isa($obj, $role) }); #no roles yet
}

# boxes a List<Variable>. SCHLIEMEL WAS HERE
# we can't use sigs on push and unshift because $x loses the flat bit
my class LLArray {
    method push { Q:CgOp { (prog
      [rawcall (unbox List<Variable> (@ (pos 0))) Add (pos 1)] [pos 0]) } }
    method shift() { Q:CgOp { (withtypes $f Variable $lv List<Variable>
      [l $lv (unbox List<Variable> (@ (l self)))]
      [l $f (getindex (int 0) (l $lv))]
      [rawcall (l $lv) RemoveAt (int 0)]
      [l $f]) } }
    method unshift { Q:CgOp { (prog
      [rawcall (unbox List<Variable> (@ (pos 0))) Insert (int 0) (pos 1)]
      [pos 0]) } }
    method first-flattens() { Q:CgOp {
      (box Bool (getfield islist (getfield lv (getindex (int 0)
        (unbox List<Variable> (@ (l self))))))) } }
    method elems() { Q:CgOp {
      (box Num (cast Double (getfield Count (unbox List<Variable>
        (@ (l self)))))) } }
    method Bool() { ?( self.elems ) }
    method new(*@v) { Q:CgOp { (varattr rest (@ (l @v))) } }
    method at-pos($i) {
        Q:CgOp { (getindex (cast Int32 (unbox Double (@ (l $i))))
                   (unbox List<Variable> (@ (l self)))) }
    }
}

my class Iterator {
    has $.valid;
    has $.value;
    has $.next;
    # subclasses must provide .validate
}

my class EMPTY { }

my class List { ... }

sub unfold-iter($fn) {
    my class UnfoldIterator is Iterator {
        has $.fun;
        method validate() {
            $!valid = 1;
            my $f = $!fun;
            $!next = UnfoldIterator.RAWCREATE("valid", 0, "value", Any, "next",
                Any, "fun", $f);
            Q:CgOp {
                (prog
                  [setindex value (getfield slots
                      (cast DynObject (@ (l self))))
                    (subcall (@ (l $f)))]
                  [null Variable])
            };
        }
    }
    UnfoldIterator.RAWCREATE("valid", 0, "value", Any, "next",
        Any, "fun", $fn);
}

sub unfold($fn) {
    my @l := List.RAWCREATE("flat", 1, "items", LLArray.new(),
        "rest", LLArray.new(unfold-iter($fn)));
    @l;
}

sub flat(*@x) { @x }

my class Whatever { }

my class Parcel is Cool {
    # $!ll

    method flat() {
        my @x := self;
        List.RAWCREATE("flat", 1, "items", LLArray.new(),
            "rest", LLArray.new(@x));
    }

    method iterator() {
        my $ll = $!ll;
        my $it = Iterator.RAWCREATE("valid", 1, "value", Any, "next", Any);
        $it.value = EMPTY;
        my $ix = ($ll.elems - 1);

        while $ix >= 0 {
            my $nit = Iterator.RAWCREATE("valid", 1, "next", Any);
            $nit.next = $it;
            $it = $nit;
            Q:CgOp {
                (prog
                  [setindex value (getfield slots
                      (cast DynObject (@ (l $it))))
                    (methodcall (l $ll) at-pos (l $ix))]
                  [null Variable])
            };
            $ix--;
        }

        $it;
    }
}

sub infix:<,>(*@v) {
    my @r := Parcel.RAWCREATE("ll", Q:CgOp { (varattr rest (@ (l @v))) });
    @r;
}

# Maybe this should be a constant, but constants are currently forced to
# scalar-nature (TODO)
sub Nil {
    state @n;
    START {
        @n := Parcel.RAWCREATE("ll", LLArray.new);
    }
    @n;
}

my class List is Cool {
    has @!items;
    has @!rest;
    has $!flat;
    method flat() {
        my @x := self;
        my @y := List.RAWCREATE("flat", 1, "items", LLArray.new(),
            "rest", LLArray.new(@x));
        @y;
    }

    method fill($nr) {
        my $i = $!items;
        my $r = $!rest;
        while $i.elems < $nr && $r {
            if $!flat && $r.first-flattens {
                $r.unshift($r.shift.iterator);
            } else {
                my $v := $r.shift;

                if $v.^isa(EMPTY) {
                    # Discard summarily
                } elsif $v.^isa(Iterator) {
                    if ! $v.valid {
                        $v.validate;
                    }
                    # we can't push anything onto items because it might be
                    # EMPTY
                    if ! $v.value.^isa(EMPTY) {
                        $r.unshift($v.next);
                        $r.unshift($v.value);
                    }
                } else {
                    $i.push($v);
                }
            }
        }

        $i.elems >= $nr;
    }

    method Bool() { self.fill(1) }
    method shift() {
        self.fill(1);
        $!items.shift;
    }
    method elems() { self.fill(1000_000_000); $!items.elems; }

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

    # XXX this is wrong, it holds on to the entire list -> memory leaks
    method iterator() {
        my $x = 0;
        unfold-iter(sub () {
            $x++;
            (self.fill($x)) ?? (self.at-pos($x - 1)) !! EMPTY;
        });
    }

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

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

sub _it_shift($it) {
    if ! $it.valid {
        $it.validate;
    }
    my $oit = $it;
    $it = $it.next;
    $oit.value;
}

PRE-INIT {
    Cool.HOW.add-method("grep", anon method grep($sm) {
            my $it = self.flat.iterator;

            unfold(sub () {
                my $item = _it_shift($it);
                ($item === EMPTY) ?? EMPTY !!
                    ($item ~~ $sm) ?? $item !! Nil;
            });
        });
    Cool.HOW.add-method("map",
        anon method map($func) {
            my $it = self.flat.iterator;

            unfold(sub () {
                my $item = _it_shift($it);
                ($item === EMPTY) ?? EMPTY !! $func($item);
            });
        });
    Cool.HOW.add-method("for",
        anon method for($func) {
            my $it = self.flat.iterator;
            while $it {
                my $item = _it_shift($it);
                ($item === EMPTY) ?? ($it = Any) !! ($func($item));
            }
        });
    Cool.HOW.add-method("say", anon method say() { self.Str.say });
    Cool.HOW.add-method("chars", anon method chars() { self.Str.chars });
    Cool.HOW.add-method("substr",
        anon method substr($x,$y) { self.Str.substr($x,$y) });

    Cool.HOW.add-method("at-pos",
        anon method at-pos($i) { self.flat.at-pos($i) });
    Cool.HOW.add-method("elems", anon method elems() { self.flat.elems });
    Cool.HOW.add-method("iterator",
        anon method iterator() { self.flat.iterator });
    Cool.HOW.add-method("join",
        anon method join($sep) { self.flat.join($sep) });
}

my class CallFrame {
    # major fudge until Mu starts treating the RI with respect
    method Bool    { True }
    method defined { True }
    method Str     { "callframe" }

    method caller() { Q:CgOp {
        (letn c (getfield caller (cast Frame (@ (l self))))
          (ternary
            (!= (letvar c) (null Frame))
            (ns (letvar c))
            (l Any)))
    } }
    method outer() { Q:CgOp {
        (letn c (getfield outer (cast Frame (@ (l self))))
          (ternary
            (!= (letvar c) (null Frame))
            (ns (letvar c))
            (l Any)))
    } }

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

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

PRE-INIT { Q:CgOp { (prog
    [rawsset Kernel.CallFrameMO (getfield klass
        (cast DynObject (@ (l CallFrame))))]
    [null Variable])
} }

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

{YOU_ARE_HERE}