#!/usr/bin/perl
#

package S2::NodeTerm;

use strict;
use S2::Node;
use S2::NodeExpr;
use S2::NodeArrayLiteral;
use S2::NodeArguments;

use vars qw($VERSION @ISA
            $INTEGER $STRING $BOOL $VARREF $SUBEXPR
            $DEFINEDTEST $SIZEFUNC $REVERSEFUNC $ISNULLFUNC
            $NEW $NEWNULL $FUNCCALL $METHCALL $ARRAY $OBJ_INTERPOLATE);

$VERSION = '1.0';
@ISA = qw(S2::NodeExpr);

$INTEGER = 1;
$STRING = 2;
$BOOL = 3;
$VARREF = 4;
$SUBEXPR = 5;
$DEFINEDTEST = 6;
$SIZEFUNC = 7;
$REVERSEFUNC = 8;
$ISNULLFUNC = 12;
$NEW = 9;
$NEWNULL = 13;
$FUNCCALL = 10;
$METHCALL = 11;
$ARRAY = 14;
$OBJ_INTERPOLATE = 15;

sub new {
    my ($class, $n) = @_;
    my $node = new S2::NodeExpr;
    bless $node, $class;
}

sub canStart {
    my ($class, $toker) = @_;
    my $t = $toker->peek();

    return $t->isa('S2::TokenIntegerLiteral') ||
        $t->isa('S2::TokenStringLiteral') ||
        $t->isa('S2::TokenIdent') ||
        $t == $S2::TokenPunct::DOLLAR ||
        $t == $S2::TokenPunct::LPAREN ||
        $t == $S2::TokenPunct::LBRACK ||
        $t == $S2::TokenPunct::LBRACE ||
        $t == $S2::TokenKeyword::DEFINED ||
        $t == $S2::TokenKeyword::TRUE ||
        $t == $S2::TokenKeyword::FALSE ||
        $t == $S2::TokenKeyword::NEW ||
        $t == $S2::TokenKeyword::SIZE ||
        $t == $S2::TokenKeyword::REVERSE ||
        $t == $S2::TokenKeyword::ISNULL ||
        $t == $S2::TokenKeyword::NULL;
}

sub getType {
    my ($this, $ck, $wanted) = @_;
    return $this->{'_cache_type'} if exists $this->{'_cache_type'};
    $this->{'_cache_type'} = _getType($this, $ck, $wanted);
}

sub _getType {
    my ($this, $ck, $wanted) = @_;
    my $type = $this->{'type'};

    if ($type == $INTEGER) { return $S2::Type::INT; }

    if ($type == $STRING) {
        return $this->{'nodeString'}->getType($ck, $S2::Type::STRING)
            if $this->{'nodeString'};
        if ($ck->isStringCtor($wanted)) {
            $this->{'ctorclass'} = $wanted->baseType();
            return $wanted;
        }
        return $S2::Type::STRING;
    }
    
    if ($type == $SUBEXPR) { return $this->{'subExpr'}->getType($ck, $wanted); }

    if ($type == $BOOL) { return $S2::Type::BOOL; }

    if ($type == $SIZEFUNC) {
        $this->{'subType'} = $this->{'subExpr'}->getType($ck);
        return $S2::Type::INT if
            $this->{'subType'}->isArrayOf() ||
            $this->{'subType'}->isHashOf() ||
            $this->{'subType'}->equals($S2::Type::STRING);
        S2::error($this, "Can't use size on expression that's not a string, hash or array.");
    }

    if ($type == $REVERSEFUNC) {
        $this->{'subType'} = $this->{'subExpr'}->getType($ck);

        # reverse a string
        return $S2::Type::STRING if 
            $this->{'subType'}->equals($S2::Type::STRING);

        # reverse an array
        return $this->{'subType'} if
            $this->{'subType'}->isArrayOf();

        S2::error($this, "Can't reverse on expression that's not a string or array.");
    }

    if ($type == $ISNULLFUNC || $type == $DEFINEDTEST) {
        my $op = ($type == $ISNULLFUNC) ? "isnull" : "defined";
        $this->{'subType'} = $this->{'subExpr'}->getType($ck);

        if ($this->{'subExpr'}->isa('S2::NodeTerm')) {
            my $nt = $this->{'subExpr'};
            if ($nt->{'type'} != $VARREF && $nt->{'type'} != $FUNCCALL &&
                $nt->{'type'} != $METHCALL) {
                S2::error($this, "$op must only be used on an object variable, ".
                          "function call or method call.");
            }
        } else {
            S2::error($this, "$op must only be used on an object variable, ".
                      "function call or method call.");
        }

        # can't be used on arrays and hashes
        unless ($this->{'subType'}->isSimple()) {
            S2::error($this, "Can't use $op on an array or hash.");
        }
        
        # not primitive types either
        if ($this->{'subType'}->isPrimitive()) {
            S2::error($this, "Can't use $op on primitive types.");
        }
        
        # nor void
        if ($this->{'subType'}->equals($S2::Type::VOID)) {
            S2::error($this, "Can't use $op on a void value.");
        }
        
        return $S2::Type::BOOL;
    }

    if ($type == $NEW || $type == $NEWNULL) {
        my $clas = $this->{'newClass'}->getIdent();
        if ($clas eq "int" || $clas eq "string") {
            S2::error($this, "Can't use 'new' with primitive type '$clas'");
        }
        my $nc = $ck->getClass($clas);
        unless ($nc) {
            S2::error($this, "Can't instantiate unknown class.");
        }
        return new S2::Type $clas;
    }

    if ($type == $VARREF) {
        unless ($ck->getInFunction()) {
            S2::error($this, "Can't reference a variable outside of a function.");
        }
        return $this->{'var'}->getType($ck, $wanted);
    }

    if ($type == $METHCALL || $type == $FUNCCALL) {
        S2::error($this, "Can't call a function or method outside of a function")
            unless $ck->getInFunction();

        if ($type == $METHCALL) {
            my $vartype = $this->{'var'}->getType($ck, $wanted);
            S2::error($this, "Cannot call a method on an array or hash")
                unless $vartype->isSimple();

            $this->{'funcClass'} = $vartype->toString;
            
            my $methClass = $ck->getClass($this->{'funcClass'});
            S2::error($this, "Can't call a method on an instance of an undefined class")
                unless $methClass;
        }

          $this->{'funcID'} = 
              S2::Checker::functionID($this->{'funcClass'},
                                      $this->{'funcIdent'}->getIdent(),
                                      $this->{'funcArgs'}->typeList($ck));
          $this->{'funcBuiltin'} = $ck->isFuncBuiltin($this->{'funcID'});

          $this->{'funcID_noclass'} = 
              S2::Checker::functionID(undef,
                                      $this->{'funcIdent'}->getIdent(),
                                      $this->{'funcArgs'}->typeList($ck));
          
          my $t = $ck->functionType($this->{'funcID'});
          $this->{'funcNum'} = $ck->functionNum($this->{'funcID'})
              unless $this->{'funcBuiltin'};
          
          S2::error($this, "Unknown function $this->{'funcID'}")
              unless $t;
          
          return $t;
    }

    if ($type == $ARRAY) {
        return $this->{'subExpr'}->getType($ck, $wanted);
    }

    S2::error($this, "Unknown NodeTerm type");
}

sub isLValue {
    my $this = shift;
    return 1 if $this->{'type'} == $VARREF;
    return $this->{'subExpr'}->isLValue()
        if $this->{'type'} == $SUBEXPR;
    return 0;
}

# make the object interpolate in a string
sub makeAsString {
    my ($this, $ck) = @_;

    if ($this->{'type'} == $STRING) {
        return $this->{'nodeString'}->makeAsString($ck);
    }
    return 0 unless $this->{'type'} == $VARREF;

    my $t = $this->{'var'}->getType($ck);
    return 0 unless $t->isSimple();
    
    my $bt = $t->baseType;
    
    # class has .toString() or .as_string() method?
    if (my $methname = $ck->classHasToString($bt)) {
        # let's change this VARREF into a METHCALL!
        # warning: ugly hacks ahead...
        my $funcID = "${bt}::$methname()";
        if ($ck->isFuncBuiltin($funcID)) {
            # builtins map to a normal function call.
            # the builtin function is responsible for checking if the
            # object is S2::check_defined() and then returning nothing.
            $this->{'type'} = $METHCALL;
            $this->{'funcIdent'} = new S2::TokenIdent $methname;
            $this->{'funcClass'} = $bt;
            $this->{'funcArgs'} = new S2::NodeArguments; # empty
            $this->{'funcID_noclass'} = "$methname()";
            $this->{'funcID'} = $funcID;
            $this->{'funcBuiltin'} = 1;
        } else {
            # if it's S2-level as_string(), then we call
            # S2::interpolate_object($ctx, "ClassName", $obj, $methname)
            $this->{'type'} = $OBJ_INTERPOLATE;
            $this->{'funcClass'} = $bt;
            $this->{'objint_method'} = $methname;

        }
        return 1;
    }

    # class has $.as_string string member?
    if ($ck->classHasAsString($bt)) {
        $this->{'var'}->useAsString();
        return 1;
    }
    
    return 0;    
}

sub parse {
    my ($class, $toker) = @_;
    my $nt = new S2::NodeTerm;
    my $t = $toker->peek();

    # integer literal
    if ($t->isa('S2::TokenIntegerLiteral')) {
        $nt->{'type'} = $INTEGER;
        $nt->{'tokInt'} = $nt->eatToken($toker);
        return $nt;
    }

    # boolean literal
    if ($t == $S2::TokenKeyword::TRUE ||
        $t == $S2::TokenKeyword::FALSE) {
        $nt->{'type'} = $BOOL;
        $nt->{'boolValue'} = $t == $S2::TokenKeyword::TRUE;
        $nt->eatToken($toker);
        return $nt;
    }

    # string literal
    if ($t->isa('S2::TokenStringLiteral')) {
        my $ts = $t;
        my $ql = $ts->getQuotesLeft();
        my $qr = $ts->getQuotesRight();

        if ($qr) {
            # whole string literal
            $nt->{'type'} = $STRING;
            $nt->{'tokStr'} = $nt->eatToken($toker);
            $nt->setStart($nt->{'tokStr'});
            return $nt;
        }

        # interpolated string literal (turn into a subexpr)
        my $toklist = [];
        $toker->pushInString($ql);
        
        $nt->{'type'} = $STRING;
        $nt->{'tokStr'} = $nt->eatToken($toker);
        push @$toklist, $nt->{'tokStr'}->clone();
        $nt->{'tokStr'}->setQuotesRight($ql);
        
        my $lhs = $nt;
        my $filepos = $nt->{'tokStr'}->getFilePos();
        
        my $loop = 1;
        while ($loop) {
            my $rhs = undef;
            my $tok = $toker->peek();
            unless ($tok) {
                S2::error($tok, "Unexpected end of file.  Unclosed string literal?");
            }
            if ($tok->isa('S2::TokenStringLiteral')) {
                $rhs = new S2::NodeTerm;
                $ts = $tok;
                $rhs->{'type'} = $STRING;
                $rhs->{'tokStr'} = $rhs->eatToken($toker);
                push @$toklist, $rhs->{'tokStr'}->clone();

                $loop = 0 if $ts->getQuotesRight() == $ql;
                $ts->setQuotesRight($ql);
                $ts->setQuotesLeft($ql);
            } elsif ($tok == $S2::TokenPunct::DOLLAR) {
                $rhs = parse S2::NodeTerm $toker;
                push @$toklist, @{$rhs->getTokenList()};
            } else {
                S2::error($tok, "Error parsing interpolated string: " . $tok->toString);
            }
            
            # don't make a sum out of a blank string on either side
            my $join = 1;
            if ($lhs->isa('S2::NodeTerm') &&
                $lhs->{'type'} == $STRING &&
                length($lhs->{'tokStr'}->getString()) == 0) 
            {
                $lhs = $rhs;
                $join = 0;
            }
            if ($rhs->isa('S2::NodeTerm') &&
                $rhs->{'type'} == $STRING &&
                length($rhs->{'tokStr'}->getString()) == 0)
            {
                $join = 0;
            }

            if ($join) {
                $lhs = S2::NodeSum->new($lhs, $S2::TokenPunct::PLUS, $rhs);
            }
        }
        
        $toker->popInString();

        $lhs->setTokenList($toklist);
        $lhs->setStart($filepos);
        
        my $rnt = new S2::NodeTerm;
        $rnt->{'type'} = $STRING;
        $rnt->{'nodeString'} = $lhs;
        $rnt->addNode($lhs);

        return $rnt;
    }
    
    # Sub-expression (in parenthesis)
    if ($t == $S2::TokenPunct::LPAREN) {
        $nt->{'type'} = $SUBEXPR;
        $nt->setStart($nt->eatToken($toker));

        $nt->{'subExpr'} = parse S2::NodeExpr $toker;
        $nt->addNode($nt->{'subExpr'});

        $nt->requireToken($toker, $S2::TokenPunct::RPAREN);
        return $nt;
    }

    # defined test
    if ($t == $S2::TokenKeyword::DEFINED) {
        $nt->{'type'} = $DEFINEDTEST;
        $nt->setStart($nt->eatToken($toker));
        $nt->{'subExpr'} = parse S2::NodeTerm $toker;
        $nt->addNode($nt->{'subExpr'});
        return $nt;
    }

    # reverse function
    if ($t == $S2::TokenKeyword::REVERSE) {
        $nt->{'type'} = $REVERSEFUNC;
        $nt->eatToken($toker);
        $nt->{'subExpr'} = parse S2::NodeTerm $toker;
        $nt->addNode($nt->{'subExpr'});
        return $nt;
    }

    # size function
    if ($t == $S2::TokenKeyword::SIZE) {
        $nt->{'type'} = $SIZEFUNC;
        $nt->eatToken($toker);
        $nt->{'subExpr'} = parse S2::NodeTerm $toker;
        $nt->addNode($nt->{'subExpr'});
        return $nt;
    }

    # isnull function
    if ($t == $S2::TokenKeyword::ISNULL) {
        $nt->{'type'} = $ISNULLFUNC;
        $nt->eatToken($toker);
        $nt->{'subExpr'} = parse S2::NodeTerm $toker;
        $nt->addNode($nt->{'subExpr'});
        return $nt;
    }

    # new andnull
    if ($t == $S2::TokenKeyword::NEW ||
        $t == $S2::TokenKeyword::NULL) {
        $nt->{'type'} = $t == $S2::TokenKeyword::NEW ? $NEW : $NEWNULL;
        $nt->eatToken($toker);
        $nt->{'newClass'} = $nt->getIdent($toker);
        return $nt;
    }

    # VarRef
    if ($t == $S2::TokenPunct::DOLLAR) {
        $nt->{'type'} = $VARREF;
        $nt->{'var'} = parse S2::NodeVarRef $toker;
        $nt->addNode($nt->{'var'});

        # check for -> after, like: $object->method(arg1, arg2, ...)
        if ($toker->peek() == $S2::TokenPunct::DEREF) {
            $nt->{'derefLine'} = $toker->peek()->getFilePos()->line;
            $nt->eatToken($toker);
            $nt->{'type'} = $METHCALL;
            # don't return... parsing continues below.
        } else {
            return $nt;
        }
    }

    # function/method call
    if ($nt->{'type'} == $METHCALL || $t->isa('S2::TokenIdent')) {
        $nt->{'type'} = $FUNCCALL unless $nt->{'type'} == $METHCALL;
        $nt->{'funcIdent'} = $nt->getIdent($toker);
        $nt->{'funcArgs'} = parse S2::NodeArguments $toker;
        $nt->addNode($nt->{'funcArgs'});
        return $nt;
    }

    # array/hash literal
    if (S2::NodeArrayLiteral->canStart($toker)) {
        $nt->{'type'} = $ARRAY;
        $nt->{'subExpr'} = parse S2::NodeArrayLiteral $toker;
        $nt->addNode($nt->{'subExpr'});
        return $nt;
    }
    
    S2::error($toker->peek(), "Can't finish parsing NodeTerm");
}


sub asS2 {
    my ($this, $o) = @_;
    die "NodeTerm::asS2(): not implemented";
}

sub asPerl {
    my ($this, $bp, $o) = @_;
    my $type = $this->{'type'};

    if ($type == $INTEGER) {
        $this->{'tokInt'}->asPerl($bp, $o);
        return;
    }

    if ($type == $STRING) {
        if (defined $this->{'nodeString'}) {
            $o->write("(");
            $this->{'nodeString'}->asPerl($bp, $o);
            $o->write(")");
            return;
        }
        if ($this->{'ctorclass'}) {
            my $pkg = $bp->getBuiltinPackage() || "S2::Builtin";
            $o->write("${pkg}::$this->{'ctorclass'}__$this->{'ctorclass'}(");
        }
        $this->{'tokStr'}->asPerl($bp, $o);
        $o->write(")") if $this->{'ctorclass'};
        return;
    }

    if ($type == $BOOL) {
        $o->write($this->{'boolValue'} ? "1" : "0");
        return;
    }

    if ($type == $SUBEXPR) {
        $o->write("(");
        $this->{'subExpr'}->asPerl($bp, $o);
        $o->write(")");
        return;
    }

    if ($type == $ARRAY) {
        $this->{'subExpr'}->asPerl($bp, $o);
        return;
    }

    if ($type == $NEW) {
        $o->write("{'_type'=>" .
                  $bp->quoteString($this->{'newClass'}->getIdent()) .
                  "}");
        return;
    }

    if ($type == $NEWNULL) {
        $o->write("{'_type'=>" .
                  $bp->quoteString($this->{'newClass'}->getIdent()) .
                  ", '_isnull'=>1}");
        return;
    }

    if ($type == $REVERSEFUNC) {
        if ($this->{'subType'}->isArrayOf()) {
            $o->write("[reverse(\@{");
            $this->{'subExpr'}->asPerl($bp, $o);
            $o->write("})]");
        } elsif ($this->{'subType'}->equals($S2::Type::STRING)) {
            $o->write("reverse(");
            $this->{'subExpr'}->asPerl($bp, $o);
            $o->write(")");
        }
        return;
    }

    if ($type == $SIZEFUNC) {
        if ($this->{'subType'}->isArrayOf()) {
            $o->write("scalar(\@{");
            $this->{'subExpr'}->asPerl($bp, $o);
            $o->write("})");
        } elsif ($this->{'subType'}->isHashOf()) {
            $o->write("scalar(keys \%{");
            $this->{'subExpr'}->asPerl($bp, $o);
            $o->write("})");
        } elsif ($this->{'subType'}->equals($S2::Type::STRING)) {
            $o->write("length(");
            $this->{'subExpr'}->asPerl($bp, $o);
            $o->write(")");
        }
        return;
    }

    if ($type == $DEFINEDTEST) {
        $o->write("S2::check_defined(");
        $this->{'subExpr'}->asPerl($bp, $o);
        $o->write(")");
        return;
    }

    if ($type == $ISNULLFUNC) {
        $o->write("(ref ");
        $this->{'subExpr'}->asPerl($bp, $o);
        $o->write(" ne \"HASH\" || ");
        $this->{'subExpr'}->asPerl($bp, $o);
        $o->write("->{'_isnull'})");
        return;
    }

    if ($type == $VARREF) {
        $this->{'var'}->asPerl($bp, $o);
        return;
    }

    if ($type == $OBJ_INTERPOLATE) {
        $o->write("S2::interpolate_object(\$_ctx, '$this->{'funcClass'}', ");
        $this->{'var'}->asPerl($bp, $o);
        $o->write(", '$this->{'objint_method'}()')");
        return;
    }

    if ($type == $FUNCCALL || $type == $METHCALL) {

        # builtin functions can be optimized.
        if ($this->{'funcBuiltin'}) {
            # these built-in functions can be inlined.
            if ($this->{'funcID'} eq "string(int)") {
                $this->{'funcArgs'}->asPerl($bp, $o, 0);
                return;
            }
            if ($this->{'funcID'} eq "int(string)") {
                # cast from string to int by adding zero to it
                $o->write("int(");
                $this->{'funcArgs'}->asPerl($bp, $o, 0);
                $o->write(")");
                return;
            }

            # otherwise, call the builtin function (avoid a layer
            # of indirection), unless it's for a class that has
            # children (won't know until run-time which class to call)
            my $pkg = $bp->getBuiltinPackage() || "S2::Builtin";
            $o->write("${pkg}::");
            if ($this->{'funcClass'}) {
                $o->write("$this->{'funcClass'}__");
            }
            $o->write($this->{'funcIdent'}->getIdent());
        } else {
            if ($type == $METHCALL && $this->{'funcClass'} ne "string") {
                $o->write("\$_ctx->[VTABLE]->{get_object_func_num(");
                $o->write($bp->quoteString($this->{'funcClass'}));
                $o->write(",");
                $this->{'var'}->asPerl($bp, $o);
                $o->write(",");
                $o->write($bp->quoteString($this->{'funcID_noclass'}));
                $o->write(",");
                $o->write($bp->getLayerID());
                $o->write(",");
                $o->write($this->{'derefLine'}+0);
                if ($this->{'var'}->isSuper()) {
                    $o->write(",1");
                }
                $o->write(")}->");
            } elsif ($type == $METHCALL) {
                $o->write("\$_ctx->[VTABLE]->{get_func_num(");
                $o->write($bp->quoteString($this->{'funcID'}));
                $o->write(")}->");
            } else {
                $o->write("\$_ctx->[VTABLE]->{\$_l2g_func[$this->{'funcNum'}]}->");
            }
        }

        $o->write("(\$_ctx, ");
        
        # this pointer
        if ($type == $METHCALL) {
            $this->{'var'}->asPerl($bp, $o);
            $o->write(", ");
        }
        
        $this->{'funcArgs'}->asPerl($bp, $o, 0);
        
        $o->write(")");
        return;
    }

    die "Unknown term type";
}

sub isProperty {
    my $this = shift;
    return 0 unless $this->{'type'} == $VARREF;
    return $this->{'var'}->isProperty();
}

sub isBuiltinProperty {
    my ($this, $ck) = @_;
    return 0 unless $this->{'type'} == $VARREF;
    return 0 unless $this->{'var'}->isProperty();
    my $name = $this->{'var'}->propName();
    return $ck->propertyBuiltin($name);
}