#!/usr/bin/perl
#

package S2::Checker;

use strict;
use vars qw($VERSION);

# version should be incremented whenever any internals change.
# the external mechanisms which serialize checker objects should
# then include in their hash/db/etc the version, so any change
# in version invalidates checker caches and forces a full re-compile
$VERSION = '1.0';

#    // combined (all layers)
#    private Hashtable classes;      // class name    -> NodeClass
#    private Hashtable props;        // property name -> Type
#    private Hashtable funcs;        // FuncID -> return type
#    private Hashtable funcAttr;     // FuncID -> attr string -> Boolean (has attr)
#    private LinkedList localblocks; // NodeStmtBlock scopes .. last is deepest (closest)
#    private Type returnType;
#    private String funcClass;       // current function class
#    private Hashtable derclass;     // classname  -> LinkedList<classname>
#    private boolean inFunction;     // checking in a function now?

#    // per-layer
#    private Hashtable funcDist;     // FuncID -> [ distance, NodeFunction ]
#    private Hashtable funcIDs;      // NodeFunction -> Set<FuncID>
#    private boolean hitFunction;    // true once a function has been declared/defined

#    // per function
#    private int funcNum = 0;
#    private Hashtable funcNums;     // FuncID -> Integer(funcnum)
#    private LinkedList funcNames;   // Strings

sub new
{
    my $class = shift;
    my $this = {
        'classes' => {},
        'props' => {},
        'funcs' => {},
        'funcAttr' => {},
        'derclass' => {},   # classname -> arrayref<classname>
        'localblocks' => [],
    };
    bless $this, $class;
}

sub cleanForFreeze {
    my $this = shift;
    delete $this->{'funcDist'};
    delete $this->{'funcIDs'};
    delete $this->{'hitFunction'};
    delete $this->{'funcNum'};
    delete $this->{'funcNums'};
    delete $this->{'funcNames'};
    $this->{'localBlocks'} = [];
    delete $this->{'returnType'};
    delete $this->{'funcClass'};
    delete $this->{'inFunction'};
    foreach my $nc (values %{$this->{'classes'}}) {
        $nc->cleanForFreeze();
    }
}

sub addClass {
    my ($this, $name, $nc) = @_;
    $this->{'classes'}->{$name} = $nc;

    # make sure that the list of classes that derive from 
    # this one exists.
    $this->{'derclass'}->{$name} ||= [];

    # and if this class derives from another, add ourselves
    # to that list
    my $parent = $nc->getParentName();
    if ($parent) {
        my $l = $this->{'derclass'}->{$parent};
        die "Internal error: can't append to empty list" unless $l;
        push @$l, $name;
    }
}

sub getClass {
    my ($this, $name) = @_;
    return undef unless $name;
    return $this->{'classes'}->{$name};
}

sub getParentClassName {
    my ($this, $name) = @_;
    my $nc = $this->getClass($name);
    return undef unless $nc;
    return $nc->getParentName();
}

sub isValidType {
    my ($this, $t) = @_;
    return 0 unless $t;
    return 1 if $t->isPrimitive();
    return defined $this->getClass($t->baseType());
}

# property functions
sub addProperty {
    my ($this, $name, $t, $builtin) = @_;
    $this->{'props'}->{$name} = $t;
    $this->{'prop_builtin'}->{$name} = 1 if $builtin;
}

sub propertyType {
    my ($this, $name) = @_;
    return $this->{'props'}->{$name};
}

sub propertyBuiltin {
    my ($this, $name) = @_;
    return $this->{'prop_builtin'}->{$name};
}

# return type functions (undef means no return type)
sub setReturnType {
    my ($this, $t) = @_;
    $this->{'returnType'} = $t;
}

sub getReturnType {
    shift->{'returnType'};
}

# funtion functions
sub addFunction {
    my ($this, $funcid, $t, $attrs) = @_;
    my $existing = $this->functionType($funcid);
    if ($existing && ! $existing->equals($t)) {
        S2::error(undef, "Can't override function '$funcid' with new return type.");
    }
    $this->{'funcs'}->{$funcid} = $t;

    # enable all attributes specified
    if (defined $attrs) {
        die "Internal error.  \$attrs is defined, but not a hashref."
            if ref $attrs ne "HASH";
        foreach my $k (keys %$attrs) {
            $this->{'funcAttr'}->{$funcid}->{$k} = 1;
        }
    }
}

sub functionType {
    my ($this, $funcid) = @_;
    $this->{'funcs'}->{$funcid};
}

sub checkFuncAttr {
    my ($this, $funcid, $attr) = @_;
    $this->{'funcAttr'}->{$funcid}->{$attr};
}

sub isFuncBuiltin {
    my ($this, $funcid) = @_;
    return $this->checkFuncAttr($funcid, "builtin");
}

# returns true if there's a string -> t class constructor
sub isStringCtor {
    my ($this, $t) = @_;
    return 0 unless $t && $t->isSimple();
    my $cname = $t->baseType();
    my $ctorid = "${cname}::${cname}(string)";
    my $rt = $this->functionType($ctorid);
    return $rt && $rt->isSimple() && $rt->baseType() eq $cname &&
        $this->isFuncBuiltin($ctorid);
}

# setting/getting the current function class we're in
sub setCurrentFunctionClass { my $this = shift; $this->{'funcClass'} = shift; }
sub getCurrentFunctionClass { shift->{'funcClass'}; }

# setting/getting whether in a function now
sub setInFunction { my $this = shift; $this->{'inFunction'} = shift; }
sub getInFunction { shift->{'inFunction'}; }

# variable lookup
sub pushLocalBlock {
    my ($this, $nb) = @_;  # nb  = NodeStmtBlock
    push @{$this->{'localblocks'}}, $nb;
}
sub popLocalBlock {
    my ($this) = @_;
    pop @{$this->{'localblocks'}};
}

sub getLocalScope {
    my $this = shift;
    return undef unless @{$this->{'localblocks'}};
    return $this->{'localblocks'}->[-1];
}

sub localType {
    my ($this, $local) = @_;
    return undef unless @{$this->{'localblocks'}};
    foreach my $nb (reverse @{$this->{'localblocks'}}) {
        my $t = $nb->getLocalVar($local);
        return $t if $t;
    }
    return undef;
}

sub memberType {
    my ($this, $clas, $member) = @_;
    my $nc = $this->getClass($clas);
    return undef unless $nc;
    return $nc->getMemberType($member);
}

sub setHitFunction { my $this = shift; $this->{'hitFunction'} = shift; }
sub getHitFunction { shift->{'hitFunction'}; }

sub hasDerClasses {
    my ($this, $clas) = @_;
    return scalar @{$this->{'derclass'}->{$clas}};
}

sub getDerClasses {
    my ($this, $clas) = @_;
    return $this->{'derclass'}->{$clas};
}

sub setFuncDistance {
    my ($this, $funcID, $df) = @_; # df = hashref with 'dist' and 'nf' key

    my $existing = $this->{'funcDist'}->{$funcID};

    if (! defined $existing || $df->{'dist'} < $existing->{'dist'}) {
        $this->{'funcDist'}->{$funcID} = $df;

        # keep the funcIDs hashes -> FuncID set up-to-date
        # removing the existing funcID from the old set first
        if ($existing) {
            delete $this->{'funcIDs'}->{$existing->{'nf'}}->{$funcID};
        }
        
        # add to new set
        $this->{'funcIDs'}->{$df->{'nf'}}->{$funcID} = 1;
    }
}

sub getFuncIDs {
    my ($this, $nf) = @_;
    return [ sort keys %{$this->{'funcIDs'}->{$nf}} ];
}

# per function
sub resetFunctionNums {
    my $this = shift;
    $this->{'funcNum'} = 0;
    $this->{'funcNums'} = {};
    $this->{'funcNames'} = [];
}

sub functionNum {
    my ($this, $funcID) = @_;
    my $num = $this->{'funcNums'}->{$funcID};
    unless (defined $num) {
        $num = ++$this->{'funcNum'};
        $this->{'funcNums'}->{$funcID} = $num;
        push @{$this->{'funcNames'}}, $funcID;
    }
    return $num;
}

sub getFuncNums { shift->{'funcNums'}; }
sub getFuncNames { shift->{'funcNames'}; }

# check if type 't' is a subclass of 'w'
sub typeIsa {
    my ($this, $t, $w) = @_;
    return 0 unless S2::Type->sameMods($t, $w);

    my $is = $t->baseType();
    my $parent = $w->baseType();
    while ($is) {
        return 1 if $is eq $parent;
        my $nc = $this->getClass($is);
        $is = $nc ? $nc->getParentName() : undef;
    }
    return 0;
}

# check to see if a class or parents has a "toString()" or "as_string()" method.
# returns the method name found.
sub classHasToString {
    my ($this, $clas) = @_;
    foreach my $methname (qw(toString as_string)) {
        my $et = $this->functionType("${clas}::$methname()");
        return $methname if $et && $et->equals($S2::Type::STRING);
    }
    return undef;
}

# check to see if a class or parents has an "as_string" string member
sub classHasAsString {
    my ($this, $clas) = @_;
    my $et = $this->memberType($clas, "as_string");
    return $et && $et->equals($S2::Type::STRING);
}

# ---------------

sub checkLayer {
    my ($this, $lay) = @_; # lay = Layer

    # initialize layer-specific data structures
    $this->{'funcDist'} = {};  # funcID -> "derItem" hashref ('dist' scalar and 'nf' NodeFormal)
    $this->{'funcIDs'} = {};
    $this->{'hitFunction'} = 0;

    # check to see that they declared the layer type, and that
    # it isn't bogus.
    {
        # what the S2 source says the layer is
        my $dtype = $lay->getDeclaredType();
        S2::error(undef, "Layer type not declared") unless $dtype;
        
        # what type s2compile thinks it is
        my $type = $lay->getType();

        S2::error(undef, "Layer is declared $dtype but expecting a $type layer")
            unless $type eq $dtype;

        # now that we've validated their type is okay
        $lay->setType($dtype);
    }

    my $nodes = $lay->getNodes();
    foreach my $n (@$nodes) {
        $n->check($lay, $this);
    }

    if ($lay->getType() eq "core") {
        my $mv = $lay->getLayerInfo("majorversion");
        unless (defined $mv) {
            S2::error(undef, "Core layers must declare 'majorversion' layerinfo.");
        }
    }
}

sub functionID {
    my ($clas, $func, $o) = @_;
    my $sb;
    $sb .= "${clas}::" if $clas;
    $sb .= "$func(";
    if (! defined $o) {
        # do nothing
    } elsif (ref $o && $o->isa('S2::NodeFormals')) {
        $sb .= $o->typeList();
    } else {
        $sb .= $o;
    }
    $sb .= ")";
    return $sb;
}


1;