package Schema;
package Schema::TypeName;
package Schema::Type;
package Schema::Template;
package Schema::TemplateSpec;
package Schema::Member;
package Schema::Property;

package Schema::TypeName;
use Common;

#our @ISA = qw(Object);

# можно оптимизировать производительность, создавая объект скалаяр для простых
# имен и обхект хеш для специализаций
# сделано

sub new {
    my $class = shift;
    my $this;
    
    my $name = shift;
    my @list = map { ref $_ eq 'Schema::TypeName' ? $_ : new Schema::TypeName($_) } @_;
    
    die new Exception('TypeName soud be a simple identifier',$name) if not $name =~ /^\w+$/;
    
    if (@list) {
        $this = bless {}, $class;
        $this->{Name} = $name;
        $this->{TemplateList} = \@list if @list;
    } else {
        $this = bless \$name, $class;
    }
    
    return $this;
}

sub Name {
    my $this = shift;
    return (UNIVERSAL::isa($this,'HASH') ? $this->{Name} : $$this);
}

sub Simple {
    return $_[0]->Name;
}

# список параметров типа
sub TemplateList {
    my $this = shift;
    return (UNIVERSAL::isa($this,'HASH') ? (wantarray ? @{$this->{TemplateList}} : $this->{TemplateList} ) : (wantarray ? return () : undef));
}

# имя типа является именем шаблона
sub isTemplateSpec {
    my $this = shift;
    return( UNIVERSAL::isa($this,'HASH') ? 1 : 0 );
}

sub CanonicalName {
    my $this = shift;
    
    if (UNIVERSAL::isa($this,'HASH')) {
        if (my $result = $this->{SavedCanonicalName}) {
            $result;
        } else {
            $result = $this->{Name};
            $result .= '@'. join('#',map {ref $_ eq __PACKAGE__ ? $_->CanonicalName : $_} @{$this->{TemplateList}}) . '@@';
            $this->{SavedCanonicalName} = $result;
        }
    } else {
        $$this;
    }
}

sub Canonical {
    return $_[0]->CanonicalName;
}

# Не регистрирует вновь созданных типов в таблице
# Это из-за случая, когда:
# MyClass { Hash<int> my_map; }, тоесть полученный тип Hahs<int> уже специализирован и он будет сразу инстантинорован
# DoNotCreate для специализации шаблона только существующими типами
sub Resolve {
    my ($this,$TypeTable,$DoNotCreate) = @_;
    
    if (my $type = $TypeTable->ResolveType($this,$DoNotCreate)) {
        # предполагается, что схема автоматически создает ссылки вперед на неопределенные простые типы
        return $type;
    } else {
        if ($this->isTemplateSpec) {
            return new Schema::TemplateSpec($this->Name,map {ref $_ eq __PACKAGE__ ? $_->Resolve($TypeTable,$DoNotCreate) : Schema::TypeName->new($_)->Resolve($TypeTable,$DoNotCreate)} @{$this->{TemplateList}} );
        } else {
            die new Exception("Simple type not found", $this->Name);
        }
    }
}

package Schema::TypeTable;
use Common;
our @ISA = qw(Object);

BEGIN {
    DeclareProperty(Table => ACCESS_NONE);
    DeclareProperty(NextTable => ACCESS_NONE);
}

sub CTOR {
    my ($this,$nextTable) = @_;
    $this->{$NextTable} = $nextTable;
}

sub ResolveType {
    my ($this,$TypeName,@args) = @_;
    
    if (my $Type = $this->{$Table}->{$TypeName->CanonicalName}) {
        return $Type;
    } elsif($this->{$NextTable}) {
        return $this->{$NextTable}->ResolveType($TypeName,@args);
    } else {
        return undef;
    }
}

sub RegisterType {
    my ($this,$Type) = @_;
    
    if (not $this->{$Table}->{$Type->Name->CanonicalName}) {
        $this->{$Table}->{$Type->Name->CanonicalName} = $Type;
    } else {
        die new Exception("A type already registered",$Type->Name->CanonicalName);
    }
}

sub _ListTypes {
    my $this = shift;
    return values %{$this->{$Table}};
}

sub Dispose {
    my $this = shift;
    
    $_->Dispose foreach values %{$this->{$Table} ? $this->{$Table} : {} };
    
    delete $this->{$Table};
    
    $this->SUPER::Dispose;
}

# Специализация шаблона - это имя специализируемого шаблона и параметры, которые будут ему переданы (важен порядок параметров)
# Специализация шаблона параметрами пораждает частично специализированный шаблон, который по сути также является шаблоном
# Если специализация полная, то можно создать экземпляр шаблона, тоесть полноценный тип
package Schema::TemplateSpec;
use Common;
our @ISA = qw(Object);

BEGIN {
    DeclareProperty(Name => ACCESS_READ);
    DeclareProperty(Parameters => ACCESS_READ);
    DeclareProperty(TemplateList => ACCESS_READ);
}

sub CTOR {
    my ($this,$templateName,@typeList) = @_;

    my %Params;

    $this->{$TemplateList} = \@typeList;

    # вычисляем параметры данной специализации
    my @nameList;
    foreach $typeItem (@typeList) {
        map { $Params{$_->Name} = $_ } @{$typeItem->Parameters} if $typeItem->isTemplate;
        push @nameList, $typeItem->Name;
    }

    $this->{$Parameters} = [ values %Params ];
    $this->{$Name} = new Schema::TypeName($templateName,@nameList);
}

sub isTemplate {
    1;
}

sub canInstantinate {
    my ($this) = @_;
    if (@{$this->{$Parameters}}) {
        0;
    } else {
        1;
    }
}

sub Specialize {
    my ($this,$refParams,$TypeTable) = @_;
    
    my @specializedList = map {$_->isTemplate && !$_->canInstantinate ? $_->Specialize($refParams,$TypeTable) : $_ } @{$this->{$TemplateList}};

    if ($TypeTable) {
        
        my $TypeName = new Schema::TypeName($this->Name->Name,map {$_->Name} @specializedList);
        my $templateSpec = $TypeTable->ResolveType($TypeName);
        if (not $templateSpec) {
            $templateSpec = new Schema::TemplateSpec($this->Name->Name,@specializedList);
            $TypeTable->RegisterType($templateSpec);
        }
        return $templateSpec;
    } else {
        return new Schema::TemplateSpec($this->Name->Name,@specializedList);
    }
}

# Параметр шаблона
# По сути является шаблоном типа Param_Name<T> -> T;
package Schema::Parameter;

sub new {
    my $TypeName = new Schema::TypeName($_[1]);
    bless \$TypeName,$_[0];
}

sub Name {
    ${shift()};
}

sub Specialize {
    my ($this,$refArgs) = @_;
    return $refArgs->{$$this->Name};
}

sub isTemplate {
    1;
}

sub canInstantinate {
    0;
}

sub Parameters {
    if (wantarray) {
        shift;
    } else {
        [shift];
    }
}


# Член класса
package Schema::Member;
use Common;
our @ISA = qw(Object);
our $Abstract = 1;

BEGIN {
    DeclareProperty(Name => ACCESS_READ);
}
sub CTOR {
    my($this,$name) =  @_;
    
    $this->{$Name} = $name;
}

# Член класса - свойство.
# Свойство может быть шаблоном, если шаблоном является его тип
package Schema::Property;
use Common;
our @ISA = qw(Schema::Member);

BEGIN {
    DeclareProperty(Type => ACCESS_READ);
}

sub CTOR {
    my ($this,$name,$type) = @_;
    $this->SUPER::CTOR($name);
    
    $this->{$Type} = $type or die new Exception("A type for the property must be specified",$name);
}

sub isTemplate {
    my $this = shift;
    return $this->{$Type}->isTemplate;
}

sub canInstantinate {
    my $this = shift;
    return $this->{$Type}->canInstantinate;
}

sub Instantinate {
    my ($this,$Schema) = @_;
    return new Schema::Property($this->Name,$Schema->Instantinate($this->{$Type}));
}

sub Specialize {
    my ($this,$refParams,$TypeTable) = @_;
    return new Schema::Property($this->Name,$this->{$Type}->Specialize($refParams,$TypeTable));
}

# Тип, описывает тип объекта
package Schema::Type;
use Common;
our @ISA = qw(Object);

BEGIN {
    DeclareProperty(Name => ACCESS_READ);
    DeclareProperty(Schema => ACCESS_READ);
    DeclareProperty(Members => ACCESS_READ);
    DeclareProperty(BaseList => ACCESS_READ);
    DeclareProperty(Attributes => ACCESS_READ); #hash of attributes
}

sub CTOR {
    my ($this,$argSchema,$name) = @_;
    
    $this->{$Name} = ref $name eq 'Schema::TypeName' ? $name : new Schema::TypeName($name);
    $this->{$Schema} = $argSchema;
}

sub isTemplate {
    0;
}

sub Equals {
    my ($this,$other) = @_;
    if (UNIVERSAL::isa($other,'Schema::Type')) {
        return ($this->Name->CanonicalName eq $other->Name->CanonicalName);
    } else {
        return 1;
    }
}

sub CreateProperty {
    my ($this,$PropName,$TypeName) = @_;

    $PropType = $this->_ResolveType($TypeName);

    return new Schema::Property($PropName,$PropType);
}

sub AddBase {
    my ($this,$type) = @_;
    
    $type = $this->_ResolveType($type);
    
    not $type->isType($this) or die new Exception('Cant derive from the class which is derived from self', $this->Name->CanonicalName, $type->Name->CanonicalName);
    
    push @{$this->{$BaseList}},$type;
}

sub isType {
    my ($this,$type,$maxlevel) = @_;
    
    return 0 if defined $maxlevel and $maxlevel < 0;
    my $typeName = UNIVERSAL::isa($type,'Schema::Type') ? $type->Name : $type ;
    
    return (
        $this->{$Name}->CanonicalName eq $typeName->CanonicalName ?
            1
        :
            scalar (grep {$_->isType($typeName,defined $maxlevel ? $maxlevel - 1 : undef)} $this->BaseList)
    );
}

sub ValidateType {
    my ($this,$type) = @_;
    
    die new Exception('Can\'t use an unspecialized template',$type->Name->CanonicalName) if ($type->isa('Schema::TypeTemplate'));
        
    if ($type->isTemplate and not $type->canInstantinate) {
        die new Exception('Cant use a not fully specialized template in a simple type',$type->Name->CanonicalName, $this->Name->Name) if not $this->isTemplate;
        
        my %Params = map {$_->Name->Name() , 1} @{$this->Parameters};
        my @Unresolved = grep {not $Params{$_->Name->Name}} @{$type->Parameters()};
        
        die new Exception('Not all parameters can be rsolved',map {$_->Name->Name} @Unresolved) if @Unresolved;
    }
}

sub InsertProperty {
    my ($this,$PropName,$PropType) = @_;
    
    $PropType = $this->_ResolveType($PropType);

    my $prop = new Schema::Property($PropName,$PropType);
    
    push @{$this->{$Members}}, $prop;

    return $prop;
}

sub AddMember {
    my ($this,$member) = @_;
    
    push @{$this->{$Members}},$member;
}

sub GetTypeTable {
    my $this = shift;
    return $this->{$Schema};
}

sub _ResolveType {
    my ($this,$type) = @_;
    if ($type->isa('Schema::TypeName')) {
        $type = $type->Resolve($this->GetTypeTable());
    } elsif ($type->isa('Schema::Type') or $type->isa('Schema::TemplateSpec')) {
        $this->ValidateType($type);
    } else {
        die new Exception('Invalid type',$type);
    }
    
    $type = $this->{$Schema}->Instantinate($type) if ($type->isTemplate and $type->canInstantinate and not $this->isTemplate);
    return $type;
}

sub ListMembers {
    my ($this,%options) = @_;
    
    my @members;
    
    if ($options{'foreign'}) {
        push @members, $_->isa('Schema::Type') ? $_->ListMembers(%options) : () foreach @{$this->{$BaseList} ? $this->{$BaseList} : []};
    }
    push @members, @{$this->{$Members} ? $this->{$Members} : []};
    
    return @members;
}

sub FindMembers {
    my ($this,$memberName,%options) = @_;
    
    my @members = grep { $_->Name eq $memberName} @{$this->{$Members} ? $this->{$Members} : []};
    
    if ($options{'deep'}) {
        push @members,$_->ListMembers(%options) foreach @{$this->{$BaseList} ? $this->{$BaseList} : []};
    }
    
    if(wantarray) {
        return @members;
    } else {
        return shift @members;
    }
}

sub SetAttributes {
    my ($this,%attributes) = @_;
    
    while (my ($key,$value) = each %attributes) {
        $this->{$Attributes}{$key} = $value;
    }
}

sub GetAttribute {
    my ($this,$name) = @_;
    
    return $this->{$Attributes}{$name};
}

sub _dump {
    my ($this) = @_;
    return $this->Name->CanonicalName;
}

sub Dispose {
    my ($this) = @_;
    
    undef %{$this};
    $this->SUPER::Dispose;
}

# Шаблон - праметризованный тип
package Schema::Template;
use Common;
our @ISA = qw(Schema::Type);

BEGIN {
    DeclareProperty(Parameters => ACCESS_READ);
    DeclareProperty(LocalTypes => ACCESS_NONE);

}

sub CTOR {
    my ($this,$Schema,$name,@args) = @_;
    # параметры не являются чачтью имени
    $this->SUPER::CTOR($Schema,$name);
    
    $this->{$Parameters} = [ map {new Schema::Parameter($_) } @args ];
    my $TypeTable = new Schema::TypeTable($Schema);
    $TypeTable->RegisterType($_) foreach @{$this->{$Parameters} };
    $this->{$LocalTypes} = $TypeTable;
}

sub GetTypeTable {
    my ($this) = @_;
    return $this->{$LocalTypes};
}

sub isTemplate {
    1;
}

sub Specialize {
    my ($this,$refArgs,$TypeTable) = @_;
    
    my @specializedList = map {$_->Specialize($refArgs)} @{$this->{$Parameters}};
    
    # создаем специализацию шаблона
    my $specializedType;
    
    if ($TypeTable) {
        my $TypeName = new Schema::TypeName($this->Name->Name,map {$_->Name} @specializedList);
        
        if(my $specializedType = $TypeTable->ResolveType($TypeName)) {
            return $specializedType;
        } else {
            $specializedType = new Schema::TemplateSpec($this->Name->Name, @specializedList );
            $TypeTable->RegisterType($specializedType);
            return $specializedType;
        }
    } else {
        return new Schema::TemplateSpec($this->Name->Name, @specializedList );
    }
}

sub canInstantinate {
    0;
}

# создание экземпляра шаблона.
# Создать шаблон = полностью его специализировать
# Принимает набор параметров шаблона и создает новый тип или возвращает из схемы
sub Instantinate {
    my ($this,$refArgs,$instance) = @_;

    my %ParamInstances;
    my @TemplateListNames;
    
    foreach my $param (@{$this->{$Parameters}}) {
        my $type = $refArgs->{$param->Name->Name};
        die new Exception("Parameter not specified",$param->Name->Name) if not $type;
        if ($type->isTemplate) {
            if ($type->canInstantinate) {
                $type = $this->Schema->Instantinate($type);
            } else {
                die new Exception("Parameter must be a fully speciazlied type",$param->Name->Name);
            }
        }
        
        $ParamInstances{$param->Name->Name} = $type;
        push @TemplateListNames, $type->Name;
    }
    
    # параметры представляют собой реальные типы, переходим к созданию типа
    # данная функция беусловно создает новый тип, эту функцию использует схем
    
    $instance = $this->Schema->CreateType( new Schema::TypeName($this->Name->Name,@TemplateListNames) ) if not $instance;

    $instance->SetAttributes(%{$this->Attributes}) if $this->Attributes;
    $instance->SetAttributes(
        TemplateInstance => {
            Template => $this,
            Parameters => \%ParamInstances
        }
    );
    
    foreach my $Ancestor ($this->BaseList) {
        $instance->AddBase(
            $Ancestor->isTemplate ?
                ( $Ancestor->canInstantinate ?
                    $this->Schema->Instantinate($Ancestor)
                    :
                    $this->Schema->Instantinate($Ancestor->Specialize(\%ParamInstances,$this->GetTypeTable))
                )
                :
                $Ancestor
        );
    }
    
    foreach my $Member ($this->Members) {
        $instance->AddMember(
            $Member->isTemplate ?
                ($Member->canInstantinate ?
                    $Member->Instantinate($this->Schema)
                    :
                    $Member->Specialize(\%ParamInstances,$this->GetTypeTable)->Instantinate($this->Schema)
                )
                :
                $Member
        );
    }

    return $instance;
}

sub _ResolveType {
    my ($this,$type) = @_;
    if ($type->isa('Schema::TypeName')) {
        $type = $type->Resolve($this->GetTypeTable());
        if (not $this->{$LocalTypes}->ResolveType($type->Name)) {
            $this->{$LocalTypes}->RegisterType($type);
        }
    } elsif ($type->isa('Schema::Type') or $type->isa('Schema::TemplateSpec')) {
        $this->ValidateType($type);
    } else {
        die new Exception('Invalid type',$type);
    }

    return $type;
}


package Schema;
use strict;
use Common;
our @ISA = qw(Schema::TypeTable);

BEGIN {
    DeclareProperty(PendingInstances => ACCESS_NONE);
    DeclareProperty(UnresolvedTypes => ACCESS_NONE);
}

sub CTOR {
    
}

# Схема автоматически создает ссылки вперед на несуществующие простые типы
sub ResolveType {
    my ($this,$TypeName,$DoNotCreate) = @_;
    
    if (my $type = $this->SUPER::ResolveType($TypeName)) {
        return $type;
    } else {
        if (not $TypeName->isTemplateSpec and not $DoNotCreate) {
            $type = new Schema::Type($this,$TypeName);
            $this->RegisterType($type);
            $this->{$UnresolvedTypes}->{$TypeName->CanonicalName} = $TypeName;
            return $type;
        } else {
            return undef;
        }
    }
}

sub CreateType {
    my ($this,$TypeName) = @_;
    
    $TypeName = new Schema::TypeName($TypeName) if ref $TypeName ne 'Schema::TypeName';
    
    if (my $type = $this->SUPER::ResolveType($TypeName)) {
        if ($this->{$UnresolvedTypes}->{$TypeName->CanonicalName}) {
            delete $this->{$UnresolvedTypes}->{$TypeName->CanonicalName};
            return $type;
        } else {
            die new Exception("Type already exists",$TypeName->CanonicalName);
        }
    } else {
        $type = new Schema::Type($this,$TypeName);
        $this->SUPER::RegisterType($type);
        return $type;
    }
}

sub CreateTemplate {
    my ($this,$TemplateName,@ParamNames) = @_;
    
    die new Exception("Parameters required for the template") if not @ParamNames;
    
    if (ref $TemplateName eq 'Schema::TypeName') {
        die new Exception('Template specialization is not valid name for a new template',$TemplateName->CanonicalName) if $TemplateName->isTemplateSpec;
    } else {
        $TemplateName = new Schema::TypeName($TemplateName);
    }
    
    if (my $type = $this->SUPER::ResolveType($TemplateName)) {
        die new Exception('Type already exists');
    } else {
        $type = new Schema::Template($this,$TemplateName,@ParamNames);
        $this->SUPER::RegisterType($type);
        return $type;
    }
}

# создание экземпляра шаблона
# создается новый пустой тип, добавляется в PendingInstances
sub Instantinate {
    my ($this,$TemplateSpec) = @_;
    
    # при специализации напрмер этого: T m_var; получим для инстантиниции real_type m_var; и не проверяя отдадим его на специализацию,
    # вот и обработка
    return $TemplateSpec if not $TemplateSpec->isTemplate;
    
    die new Exception('Only a template specialization can be instantinated') if ref $TemplateSpec ne 'Schema::TemplateSpec';
    die new Exception('Only fully specialized template can be instantinated') if not $TemplateSpec->canInstantinate;
    
    my $TypeName = $TemplateSpec->Name;
    
    if (my $type = $this->SUPER::ResolveType($TypeName)) {
        return $type;
    } else {
        $type = new Schema::Type($this,$TypeName);
        $this->SUPER::RegisterType($type);
        push @{$this->{$PendingInstances}},[$TemplateSpec,$type];
        return $type;
    }
}

sub Close {
    my ($this) = @_;
    
    if (keys %{$this->{$UnresolvedTypes}}) {
        die new Exception('Some type definitions are absent',keys %{$this->{$UnresolvedTypes}});
    }
    
    if ($this->{$PendingInstances}) {
        while( my $ref = shift @{$this->{$PendingInstances}} ) {
            my ($spec,$instance) = @$ref;
            if (my $typeTemplate = $this->SUPER::ResolveType( new Schema::TypeName($spec->Name->Name) )) {
                die new Exception('Can\'t instantinate a specialization of the simple type',$instance->Name->CanonicalName) if not $typeTemplate->isTemplate;
                if (scalar(@{$typeTemplate->Parameters}) == scalar(@{$spec->TemplateList})) {
                    my @Params = @{$typeTemplate->Parameters};
                    $typeTemplate->Instantinate({map { (shift @Params)->Name->Name, $_ } @{$spec->TemplateList}},$instance);
                } else {
                    die new Exception('A template parameters doesn\'t match to the specialization list',$instance->Name->CanonicalName);
                }
            } else {
                die new Exception('Can\'t instantinate a specialization, the specified template isn\'t found', $instance->Name->CanonicalName);
            }
        }
        
        delete $this->{$PendingInstances};
    }
}

sub EnumTypes {
    my ($this,%options) = @_;
    
    return grep { ($_->isTemplate and not $options{'skip_templates'}) or (not $_->isTemplate and not $options{'skip_classes'}) } $this->_ListTypes;
}

sub Dispose {
    my ($this) = @_;
    
    delete $this->{$UnresolvedTypes};
    
    $this->SUPER::Dispose;
}

1;