my module MildewCORE;

use adhoc-signatures;


##HACK
$LexicalPrelude{'&True'} := sub {::True}
$LexicalPrelude{'&False'} := sub {::False}

my knowhow int {
    method ACCEPTS($thing) {
        PRIMITIVES::ritest((|$thing),PRIMITIVES::SMOP_RI(2));
    }
}

my sub return(|$capture) {
    my $e = ::ControlExceptionReturn.new();
    $e.capture = $capture;
    $e.routine = CALLER::<&?ROUTINE>;
    $e.throw;
}




############## Operators ##############

# TODO change binds to sub definitions

$LexicalPrelude{'&infix:+:(int,int)'} := sub ($a,$b) {
    PRIMITIVES::int_add($a.FETCH,$b.FETCH);
}

$LexicalPrelude{'&infix:<:(int,int)'} := sub ($a,$b) {
    PRIMITIVES::int_less($a.FETCH,$b.FETCH);
}

$LexicalPrelude{'&infix:-:(int,int)'} := sub ($a,$b) {
    PRIMITIVES::int_substract($a.FETCH,$b.FETCH);
}

$LexicalPrelude{'&infix:==:(int,int)'} := sub ($a,$b) {
    PRIMITIVES::int_equal($a.FETCH,$b.FETCH);
}

$LexicalPrelude{'&infix:~'} := sub (|$capture) {
    my $i = 0;
    my $str = '';
    loop {
        if &infix:<==>:(int,int)($i.FETCH,$capture.elems) {
            return $str.FETCH;
        } else {
           $str = PRIMITIVES::idconst_concat($str.FETCH,$capture.positional($i.FETCH).FETCH.Str);
           $i = &infix:<+>:(int,int)($i.FETCH,1);
        }
    }
}
$LexicalPrelude{'&infix:eq'} := sub ($a,$b) {
    PRIMITIVES::idconst_eq($a.Str,$b.Str);
}
$LexicalPrelude{'&infix:ne'} := sub ($a,$b) {
    if PRIMITIVES::idconst_eq($a.Str,$b.Str) {
        False;
    } else {
        True;
    }
}
$LexicalPrelude{'&postfix:++'} := sub ($a) {
    $a = &infix:<+>:(int,int)($a,1);
}
$LexicalPrelude{'&prefix:++'} := sub ($a) {
    my $old = $a;
    $a = &infix:<+>:(int,int)($a,1);
    $old;
}

############## RoleHOW ##############

my sub copy_methods($dst,$src) {
    map(sub ($key) {
        $dst.^!methods{$key.FETCH} = $src.^!methods{$key.FETCH};
    },$src.^!methods.keys);
}
my sub copy_does($dst,$src) {
    my $i = 0;
    loop {
        if &infix:<==>:(int,int)($i,$src.^!does.elems) {
            return;
        } else {
            $dst.^!does[$i.FETCH] = $src.^!does[$i.FETCH];
            $i = &infix:<+>:(int,int)($i.FETCH,1);
        }
    }
}
my sub compose_role($obj,$role) {
    $obj.^!does.push((|$role));
    map(sub ($key) {
        if $obj.^!methods{$key.FETCH} {
            ::Exception.new.throw;
        }
        $obj.^add_method($key.FETCH,$role.^!methods{$key.FETCH}.FETCH);
    },$role.^!methods.keys);
}
my knowhow RoleHOW {
    method add_attribute($object, $privname, $attribute) {
        $object.^!attributes{$privname.FETCH} = $attribute;
    }
    method compose_role($object, $role) {
        compose_role($object,$role);
    }
    method add_method($object, $name, $code) {
        $object.^!methods{$name.FETCH} = $code
    }
    method dispatch($object, $identifier, \$capture) {
        if PRIMITIVES::idconst_eq($identifier.FETCH,'FETCH') {
            # in item context, returns itself.
            (|$object);
        } else {
            # Roles are not classes! so we're going to delegate this to a
            # punned class that does this role. For now, we're going to pun a
            # new class every time, then we'll think in some sort of caching.
            my $punned;
            if $object.^!instance_storage.exists('CACHED_PUNNED_CLASS') {
                $punned = $object.^!instance_storage{'CACHED_PUNNED_CLASS'};
            } else {
                my $class = ::p6opaque.^!CREATE;
                $class.^!how = ::PrototypeHOW;

                #XXX is it right?
                $class.^!who = $object.^!who;

                $class.^!does.push((|$object));
    #            $class.^compose_role(::LowObject);
    #            $class.^compose_role($object);
                copy_methods($class,::LowObject);
                copy_methods($class,$object);
                $punned = $class;
                $object.^!instance_storage{'CACHED_PUNNED_CLASS'} = $class;
            }
            my $delegated = ::Scalar.new($capture.delegate($punned.FETCH));
            return $punned.^dispatch($identifier.FETCH, (|$delegated));
        }
    }
}
my role LowObject {
    method new() {
        my $obj = ::p6opaque.^!CREATE;
        $obj.^!how = self.^!how;
        $obj.^!who = self.^!who;
        copy_methods($obj,self);
        copy_does($obj,self);
        if $obj.^!methods{'BUILDALL'} {
            $obj.BUILDALL;
        }
        $obj;
    }
    method ACCEPTS($obj) {
        my $role = self.^!does[0];
        my $does = False;
        map(sub ($r) {
            if PRIMITIVES::pointer_equal((|$role),(|$r)) {
                $does = True;
            } elsif self.ACCEPTS($r) {
                $does = True;
            }
        },$obj.^!does);
        $does;
    }
}

############## basic subroutines ##############

my sub map($expression,$values) {
    my $i = 0;
    my $ret = ::Array.new;
    loop {
        if &infix:<==>:(int,int)($i,$values.elems) {
            return $ret;
        } else {
           $ret.push((|$expression($values[$i.FETCH])));
           $i = &infix:<+>:(int,int)($i.FETCH,1);
        }
    }
}

my sub grep($expression,$values) {
    my $i = 0;
    my $ret = ::Array.new;
    loop {
        if &infix:<==>:(int,int)($i,$values.elems) {
            return $ret;
        } else {
           if ($expression($values[$i.FETCH])) {
              $ret.push($values[$i.FETCH].FETCH);
           } else {
           }
           $i = &infix:<+>:(int,int)($i.FETCH,1);
        }
    }
}

my sub say(|$capture) {
    my $i = 0;
    loop {
        if &infix:<==>:(int,int)($i,$capture.elems) {
            $OUT.print("\n");
            return;
        } else {
           $OUT.print($capture.positional($i.FETCH).Str);
           $i = &infix:<+>:(int,int)($i.FETCH,1);
        }
    }
}

my sub print(|$capture) {
    my $i = 0;
    loop {
        if &infix:<==>:(int,int)($i,$capture.elems) {
            return;
        } else {
           $OUT.print($capture.positional($i.FETCH).Str);
           $i = &infix:<+>:(int,int)($i.FETCH,1);
        }
    }
}

my sub not($thing) {
    if $thing {
        ::False;
    } else {
        ::True;
    }
}
$LexicalPrelude{'&prefix:not'} := &not;
$LexicalPrelude{'&prefix:!'} := &not;

############## Signatures ##############

my role ReadonlyWrapper {
    has $.value;
    method FETCH() {
        (|$!value);
    }
    method STORE($value) {
        ::Exception.new.throw;
    }
}

my role Signature {
    has $.params is rw;
    method ACCEPTS(\$capture) {
        my $i = 0;
        my $named = 0;
        my $ok = True;
        {
            map(sub ($param) {
                if $param.ACCEPTS_param($capture,$i,$named) {
                } else {
                    ::Exception.new.throw;
                }
            },self.params);
            CATCH {
                $ok = False;
            }
        }

        if &infix:<==>:(int,int)($i,$capture.elems) {
            if &infix:<==>:(int,int)($named,$capture.named_count) {
                $ok;
            } else {
                False;
            }
        } else {
            False;
        }
    }
    method BIND(\$capture,$scope) {
        my $i = 0;
        map(sub ($param) {
            $param.BIND($scope,$capture,$i);
        },self.params);
    }
    method BUILDALL() {
        self.params = ::Array.new;
    }
    method compare($other) {
        my $i = 0;

        my $pos_self = grep(sub ($param) {::Positional.ACCEPTS($param.FETCH)},self.params);

        my $pos_other = grep(sub ($param) {::Positional.ACCEPTS($param.FETCH)},$other.params);

        if &infix:<==>:(int,int)($pos_self.elems,$pos_other.elems) {
        } else {
            return 0;
        }
        loop {
            if &infix:<==>:(int,int)($i,$pos_self.elems) {
                return 0;
            } else {
                my $cmp = $pos_self[$i.FETCH].compare($pos_other[$i.FETCH]);
                if &infix:<==>:(int,int)($cmp,0) {
                } else {
                    return $cmp;
                }
                $i = &infix:<+>:(int,int)($i,1);
            }
        }
    }
    method perl() {
        ":(" ~ self.params[0].perl ~ "...)";
    }
}


my role Param {
    has $.variable;
    has $.default_value;
    has $.type;
    method BUILDALL() {
        $.type = ::Any.new;
    }
    method register($sig) {
        $sig.params.push((|self));
    }
}
my role Positional {
    Positional.^compose_role(::Param);
    has $.name;
    method BIND($scope,$capture,$i is ref) {
        if $capture.named($.name.FETCH) {
            if self.variable {
                $scope{self.variable.FETCH} := self.wrap($capture.named($.name.FETCH));
            }
        } elsif &infix:<<<>>:(int,int)($i,$capture.elems) {
            if self.variable {
                $scope{self.variable.FETCH} := self.wrap($capture.positional($i.FETCH));
            }
            $i = &infix:<+>:(int,int)($i.FETCH,1);
        } elsif self.default_value {
            my $default_value = self.default_value;
            if self.variable {
                $scope{self.variable.FETCH} := self.wrap($default_value());
            }
        } else {
            return False;
        }
        True;
    }
    method ACCEPTS_param($capture,$i is ref,$named is ref) {
        if $capture.named($.name.FETCH) {
            $named = &infix:<+>:(int,int)($named.FETCH,1);
        } elsif &infix:<<<>>:(int,int)($i,$capture.elems) {
            if $.type.ACCEPTS($capture.positional($i.FETCH)) {
                $i = &infix:<+>:(int,int)($i,1);
            } else {
                return False;
            }
        } elsif self.default_value {
            return True;
        } else {
            return False;
        }
        True;
    }
    method compare($other) {
        if $other.type.ACCEPTS(self.type) {
            if self.type.ACCEPTS($other.type) {
                return 0;
            } else {
                return &infix:<->:(int,int)(0,1);
            }
        } else {
            if self.type.ACCEPTS($other.type) {
                return 1;
            } else {
                return 0;
            }
        }
    }
}
my role RefParam {
    RefParam.^compose_role(::Positional);
    method wrap($arg) {
        $arg;
    }
}
my role ReadonlyParam {
    ReadonlyParam.^compose_role(::Positional);
    method wrap($arg) {
        my $wrapper = ReadonlyWrapper.new;
        $wrapper.value = $arg;
        $wrapper.^!is_container = 1;
        $wrapper.FETCH;
        (|$wrapper);
    }
    method perl() {
        self.variable
    }
}

my role NamedReadonlyParam {
    NamedReadonlyParam.^compose_role(::Param);
    has $.name;
    method BIND($scope,$capture,$i) {
        my $arg = $capture.named(self.name.FETCH);
        my $wrapper = ReadonlyWrapper.new;
        $wrapper.value = $arg;
        $wrapper.^!is_container = 1;
        $wrapper.FETCH;
        $scope{self.variable.FETCH} := (|$wrapper);
    }
    method ACCEPTS_param($capture,$i is ref,$named is ref) {
        if $capture.named($.name.FETCH) {
            $named = &infix:<+>:(int,int)($named.FETCH,1);
        }
        True;
    }
}
my role WholeCaptureParam {
    has $.name;
    WholeCaptureParam.^compose_role(::Param);
    method ACCEPTS_param($capture,$i is ref,$named is ref) {
        $i = $capture.elems;
        $named = $capture.named_count;
    }
    method BIND($scope,$capture,$i) {
        $scope{self.variable.FETCH} = $capture;
    }
}
############## Exception ##############
my role Exception {
    method throw() {
        my $interpreter = PRIMITIVES::get_interpreter;
        my $current = $interpreter.continuation;
        loop {
            if ($current.back) {
                $current = $current.back;
                if ($current.catch) {
                    $current.catch.postcircumfix:<( )>(::capture.new(self),:cc($current.back));
                } else {
                }
            } else {
                say "uncaught exception";
                return;
            }
        }
    }
}

############## Any ##############

my role Any {
    method ACCEPTS() {
        True;
    }
}

############## Multi ##############

my role Multi {
    has $.candidates;
    has $.sorted_candidates is rw;

    my sub qsort($array) {
        if &infix:<==>:(int,int)($array.elems,0) {
            ::Array.new;
        } else {
            my $partition = $array[0].signature;

            my $left  = qsort(grep sub ($elem) {&infix:<==>:(int,int)($elem.signature.compare($partition),&infix:<->:(int,int)(0,1))},$array);
            my $equal = grep(sub ($elem) {&infix:<==>:(int,int)($elem.signature.compare($partition),0)},$array);
            my $right = qsort(grep sub ($elem) {&infix:<==>:(int,int)($elem.signature.compare($partition),1)},$array);
    
            my $result = ::Array.new;
            map(sub ($x) {$result.push($x.FETCH)},$left);
            map(sub ($x) {$result.push($x.FETCH)},$equal);
            map(sub ($x) {$result.push($x.FETCH)},$right);
            $result;
        }
    }
    method postcircumfix:<( )>(\$capture, :$cc) {
        my sub ACCEPTS($candidate) {
            $candidate.signature.ACCEPTS((|$capture));
        }
        if self.sorted_candidates {
        } else {

            self.sorted_candidates = qsort(self.candidates);
        }

        my $candidates = grep &ACCEPTS,self.sorted_candidates;

        if &infix:<==>:(int,int)($candidates.elems,1) {
            $candidates[0].postcircumfix:<( )>((|$capture), :cc($cc.FETCH));
        } elsif &infix:<==>:(int,int)($candidates.elems,0) {
            say "signature mismatch failure";
           ::Exception.new.throw;
           #my $e = ::SignatureMismatchFailure.new();
           #$e.multi = self;
           #$e.capture = $capture;
           #$e.throw;
#
        } elsif &infix:<==>:(int,int)($candidates[0].signature.compare($candidates[1].signature),&infix:<->:(int,int)(0,1)) {
            $candidates[0].postcircumfix:<( )>((|$capture), :cc($cc.FETCH));
        } else {
            say "ambiguous dispatch";
            say $candidates[0].signature.compare($candidates[1].signature);
            ::Exception.new.throw;
            #my $e = ::AmbiguousDispatchFailure.new();
            #$e.multi = self;
            #$e.capture = $capture;
            #$e.candidates = $candidates;
            #$e.throw;
        }
    }
    method BUILDALL() {
        self.candidates = ::Array.new;
    }
    method get_outer_candidates($name,$scope) {
        my $outer = $scope.outer;
        loop {
            if not($outer) { 
                return
            }
            if $outer.exists((|$name)) {
                my $i = 0;
                my $multi = $outer.lookup((|$name));
                map(sub ($candidate) {self.candidates.push((|$candidate))},$multi.candidates);
                return;
            } else {
                if $outer.outer {
                    $outer = $outer.outer;
                } else {
                    return;
                }
            }
        }
    }
}

############## fail ##############
my role Failure {
    has $.handled;
    has $.exception;
    method true() {
        $.handled = True;
        False;
    }
    method defined() {
        $.handled = True;
        False;
    }
    method FETCH() {
        self;
    }
    method throw() {
        $.exception.throw;
    }
    # UNKNOWN_METHOD is a spec def
    method UNKNOWN_METHOD($identifier) {
        $.exception.throw;
    }
}
my role DollarBang {
    has @.failures;
    method cleanup() {
        map(sub ($failure) {
            if ($failure.handled) {
            } else {
                $failure.throw;
            }
        },self.failures);
    }
}
my sub fail {
    my $failure = Failure.new;
    $failure.exception = ::Exception.new;
    $failure;
    my $e = ::ControlExceptionReturn.new();
    $e.capture = $failure;
    $e.routine = CALLER::<&?ROUTINE>;
    $e.throw;
}

############## ModuleLoader ##############

my role ModuleLoader {
    has $.cache;
    my $loader = ::MildewSOLoader.new;
    method load($module) {
        my $filename = self.resolve_filename($module);
        if $.cache{$filename.FETCH} {
        } else {
            $.cache{$filename.FETCH} = $loader.load($filename.FETCH,$LexicalPrelude.FETCH);
        }
        $.cache{$filename.FETCH};
    }
    method resolve_filename($module) {
        $module ~ '.mildew.so'
    }
    method BUILDALL() {
        $.cache = ::Hash.new;
    }
}


############## Perl5 interop ##############
my knowhow EXTERNAL {
    my $p5;
    sub use_from_perl5($module) {
        unless $p5 {
            $p5 := ::P5Interpreter.new;
        }
        $p5.eval(PRIMITIVES::idconst_concat('use ',$module.FETCH));
        $p5.eval(PRIMITIVES::idconst_concat(PRIMITIVES::idconst_concat("'",$module.FETCH),"'"));
    }
    sub eval_perl5($code) {
        unless $p5 {
            $p5 := ::P5Interpreter.new;
        }
        $p5.eval($code.FETCH.FETCH);
    }
}

############## int ##############
no adhoc-signatures;

my role int {
    method ACCEPTS($thing) {
        PRIMITIVES::ritest((|$thing),PRIMITIVES::SMOP_RI(2));
    }
}

my multi infix:<==>(int $a,int $b) {
    &infix:<==>:(int,int)($a,$b);
}

my multi infix:<!=>(int $a,int $b) {
    if &infix:<==>:(int,int)($a,$b) {
        False;
    } else {
        True;
    }
}
my multi infix:<+>(int $a,int $b) {
    &infix:<+>:(int,int)($a,$b);
}
my multi infix:<->(int $a,int $b) {
    &infix:<->:(int,int)($a,$b);
}
my multi prefix:<->(int $a) {
    &infix:<->:(int,int)(0,$a);
}

#HACK we don't support such fancy multi names so we bind to $LexicalPrelude
{
#TODO fix multi infix:<\<> {...}
my multi less(int $a,int $b) {
    &infix:<<<>>:(int,int)($a,$b);
}
my multi more(int $a,int $b) {
    if &infix:<<<>>:(int,int)($a,$b) {
        False;
    } elsif &infix:<==>:(int,int)($a,$b) {
        False;
    } else {
        True;
    }
}
#TODO fix multi infix:<\<> {...}
my multi less_or_equal(int $a,int $b) {
    &infix:<<<>>:(int,int)($a,$b) || &infix:<==>:(int,int)($a,$b);
}
my multi more_or_equal(int $a,int $b) {
    not(&infix:<<<>>:(int,int)($a,$b));
}

$LexicalPrelude{'&infix:<='} := &less_or_equal;
$LexicalPrelude{'&infix:>='} := &more_or_equal;
$LexicalPrelude{'&infix:<'} := &less;
$LexicalPrelude{'&infix:>'} := &more;

}

{YOU_ARE_HERE};