#line 1
package TestML::Runtime;
use TestML::Mo;

use TestML::Compiler;

# Since there is only ever one test runtime, it makes things a LOT cleaner to
# keep the reference to it in a global variable accessed by a method, than to
# put a reference to it into every object that needs to access it.
our $self;

has base => default => sub {$0 =~ m!(.*)/! ? $1 : "."};   # Base directory
has testml => ();       # TestML document filename, handle or text
has bridge => ();       # Bridge transform module

# XXX Add TestML.pm support for -library keyword.
has library => default => sub {[]};    # Transform library modules

has function => ();         # Current function executing
has planned => default => sub {0};     # plan() has been called
has test_number => default => sub {0}; # Number of tests run so far

sub BUILD {
    my $self = $TestML::Runtime::self = shift;
    $self->function($self->compile_testml);
    $self->load_variables;
    $self->load_transform_module('TestML::Library::Standard');
    $self->load_transform_module('TestML::Library::Debug');
    if ($self->bridge) {
        $self->load_transform_module($self->bridge);
    }
}

# XXX Move to TestML::Adapter
sub title { }
sub plan_begin { }
sub plan_end { }

sub run {
    my $self = shift;

    my $function = $self->function;
    my $context = TestML::None->new;
    my $args = [];

    $self->run_function($self->function, $context, $args);

    $self->run_plan();
    $self->plan_end();
}

# XXX - TestML exception handling needs to happen at the function level, not
# just at the expression level. Not yet handled here.
sub run_function {
    my $self = shift;
    my $function = shift;
    my $context = shift;
    my $args = shift;

    my $signature = $function->signature;
    die sprintf(
        "Function received %d args but expected %d",
        scalar(@$args),
        scalar(@$signature),
    ) if @$signature and @$args != @$signature;
    $function->setvar('Self', $context);
    for (my $i = 0; $i < @$signature; $i++) {
        my $arg = $args->[$i];
        $arg = $self->run_expression($arg)
            if ref($arg) eq 'TestML::Expression';
        $function->setvar($signature->[$i], $arg);
    }

    my $parent = $self->function;
    $self->function($function);

    for my $statement (@{$function->statements}) {
        $self->run_statement($statement);
    }

    $self->function($parent);

    return TestML::None->new;
}

sub run_statement {
    my $self = shift;
    my $statement = shift;
    my $blocks = @{$statement->points}
        ? $self->select_blocks($statement->points)
        : [1];
    for my $block (@$blocks) {
        $self->function->setvar('Block', $block) if ref($block);
        my $context = $self->run_expression($statement->expression);
        if (my $assertion = $statement->assertion) {
            $self->run_assertion($context, $assertion);
        }
    }
}

sub run_assertion {
    my $self = shift;
    my $left = shift;
    my $assertion = shift;
    my $method = 'assert_' . $assertion->name;

    # Run this as late as possible.
    $self->run_plan;

    $self->test_number($self->test_number + 1);
    $self->function->setvar(
        TestNumber => TestML::Num->new(value => $self->test_number),
    );

    # TODO - Should check 
    my $results = ($left->type eq 'List')
        ? $left->value
        : [ $left ];
    for my $result (@$results) {
        if (@{$assertion->expression->units}) {
            my $right = $self->run_expression($assertion->expression);
            my $matches = ($right->type eq 'List')
                ? $right->value
                : [ $right ];
            for my $match (@$matches) {
                $self->$method($result, $match);
            }
        }
        else {
            $self->$method($result);
        }
    }
}

sub run_expression {
    my $self = shift;
    my $prev_expression = $self->function->expression;
    my $expression = shift;
    $self->function->expression($expression);

    my $units = $expression->units;
    my $context = TestML::None->new;

    for (my $i = 0; $i < @$units; $i++) {
        my $unit = $units->[$i];
        if ($expression->error) {
            next unless
                $unit->isa('TestML::Transform') and
                $unit->name eq 'Catch';
        }
        if ($unit->isa('TestML::Object')) {
            $context = $unit;
            next;
        }
        if ($unit->isa('TestML::Function')) {
            $context = $unit;
            next;
        }
        die "Unexpected unit: $unit" unless $unit->isa('TestML::Transform');
        my $callable = $self->function->getvar($unit->name)
            or die "Can't find transform '${\$unit->name}'";
        my $args = $unit->args;
        if ($callable->isa('TestML::Native')) {
            $context = $self->run_native($callable->value, $context, $args);
        }
        elsif ($callable->isa('TestML::Object')) {
            $context = $callable;
        }
        elsif ($callable->isa('TestML::Function')) {
            if ($i or $unit->explicit_call) {
                my $points = $self->function->getvar('Block')->points;
                for my $key (keys %$points) {
                    $callable->setvar($key, TestML::Str->new(value => $points->{$key}));
                }
                $context = $self->run_function($callable, $context, $args);
            }
            $context = $callable;
        }
        else {
            ZZZ $expression, $unit, $callable;
        }
    }
    if ($expression->error) {
        die $expression->error;
    }
    $self->function->expression($prev_expression);
    return $context;
}

sub run_native {
    my $self = shift;
    my $function = shift;
    my $context = shift;
    my $args = shift;
    my $value = eval {
        &$function(
            $context,
            map {
                (ref($_) eq 'TestML::Expression')
                ? $self->run_expression($_)
                : $_
            } @$args
        );
    };
    if ($@) {
        $self->function->expression->error($@);
        $context = TestML::Error->new(value => $@);
    }
    elsif (UNIVERSAL::isa($value, 'TestML::Object')) {
        $context = $value;
    }
    else {
        $context = $self->object_from_native($value);
    }
    return $context;
}

sub select_blocks {
    my $self = shift;
    my $wanted = shift;
    my $selected = [];

    OUTER: for my $block (@{$self->function->data}) {
        my %points = %{$block->points};
        next if exists $points{SKIP};
        for my $point (@$wanted) {
            next OUTER unless exists $points{$point};
        }
        if (exists $points{ONLY}) {
            @$selected = ($block);
            last;
        }
        push @$selected, $block;
        last if exists $points{LAST};
    }
    return $selected;
}

sub object_from_native {
    my $self = shift;
    my $value = shift;
    return
        not(defined $value) ? TestML::None->new :
        ref($value) eq 'ARRAY' ? TestML::List->new(value => $value) :
        $value =~ /^-?\d+$/ ? TestML::Num->new(value => $value + 0) :
        "$value" eq "$TestML::Constant::True" ? $value :
        "$value" eq "$TestML::Constant::False" ? $value :
        "$value" eq "$TestML::Constant::None" ? $value :
        TestML::Str->new(value => $value);
}

sub compile_testml {
    my $self = shift;
    my $path = ref($self->testml)
        ? $self->testml
        : join '/', $self->base, $self->testml;
    my $function = TestML::Compiler->new(base => $self->base)->compile($path)
        or die "TestML document failed to compile";
    return $function;
}

sub load_variables {
    my $self = shift;
    my $global = $self->function->outer;
    $global->setvar(Block => TestML::Block->new);
    $global->setvar(Label => TestML::Str->new(value => '$BlockLabel'));
    $global->setvar(True => $TestML::Constant::True);
    $global->setvar(False => $TestML::Constant::False);
    $global->setvar(None => $TestML::Constant::None);
}

sub load_transform_module {
    my $self = shift;
    my $module_name = shift;
    if ($module_name ne 'main') {
        eval "require $module_name; 1"
            or die "Can't use $module_name:\n$@";
    }

    my $global = $self->function->outer;
    no strict 'refs';
    for my $key (sort keys %{"$module_name\::"}) {
        next if $key eq "\x16";
        my $glob = ${"$module_name\::"}{$key};
        if (my $function = *$glob{CODE}) {
            $global->setvar(
                $key => TestML::Native->new(value => $function),
            );
        }
        elsif (my $object = *$glob{SCALAR}) {
            if (ref($$object)) {
                $global->setvar($key => $$object);
            }
        }
    }
}

sub get_label {
    my $self = shift;
    my $label = $self->function->getvar('Label')->value;
    sub label {
        my $self = shift;
        my $var = shift;
        my $block = $self->function->getvar('Block');
        return $block->label if $var eq 'BlockLabel';
        if (my $v = $block->points->{$var}) {
            $v =~ s/\n.*//s;
            $v =~ s/^\s*(.*?)\s*$/$1/;
            return $v;
        }
        if (my $v = $self->function->getvar($var)) {
            return $v->value;
        }
    }
    $label =~ s/\$(\w+)/label($self, $1)/ge;
    return $label ? ($label) : ();
}

sub run_plan {
    my $self = shift;
    if (! $self->planned) {
        $self->title();
        $self->plan_begin();
        $self->planned(1);
    }
}

sub get_error {
    my $self = shift;
    return $self->function->expression->error;
}

sub clear_error {
    my $self = shift;
    return $self->function->expression->error(undef);
}

sub throw {
    require Carp;
    Carp::croak $_[1];
}

#-----------------------------------------------------------------------------
package TestML::Function;
use TestML::Mo;

has type => default => sub {'Func'};        # Functions are TestML typed objects
# XXX Make this a featherweight reference.
has signature => default => sub {[]};       # Input variable names
has namespace => default => sub {{}};       # Lexical scoped variable stash
has statements => default => sub {[]};      # Exexcutable code statements
has data => default => sub{[]};             # Data section scoped to this function

# Runtime pointers to current objects.
has expression => ();
has block => ();

my $outer = {};
sub outer { @_ == 1 ? $outer->{$_[0]} : ($outer->{$_[0]} = $_[1]) }

sub getvar {
    my $self = shift;
    my $name = shift;
    while ($self) {
        if (my $object = $self->namespace->{$name}) {
            return $object;
        }
        $self = $self->outer;
    }
    return;
}

sub setvar {
    my $self = shift;
    my $name = shift;
    my $object = shift;
    $self->namespace->{$name} = $object;
    return;
}

sub forgetvar {
    my $self = shift;
    my $name = shift;
    delete $self->namespace->{$name};
    return;
}

#-----------------------------------------------------------------------------
package TestML::Statement;
use TestML::Mo;

has expression => default => sub {TestML::Expression->new};
has assertion => ();
has points => default => sub {[]};

#-----------------------------------------------------------------------------
package TestML::Expression;
use TestML::Mo;

has units => default => sub {[]};
has error => ();

#-----------------------------------------------------------------------------
package TestML::Assertion;
use TestML::Mo;

has name => ();
has expression => default => sub {TestML::Expression->new};

#-----------------------------------------------------------------------------
package TestML::Transform;
use TestML::Mo;

has name => ();
has args => default => sub {[]};
has explicit_call => default => 0;

#-----------------------------------------------------------------------------
package TestML::Block;
use TestML::Mo;

has label => default => sub {''};
has points => default => sub {{}};

#-----------------------------------------------------------------------------
package TestML::Object;
use TestML::Mo;

has value => ();

sub type {
    my $type = ref(shift);
    $type =~ s/^TestML::// or die "Can't find type of '$type'";
    return $type;
}

sub runtime { return $TestML::Runtime::self }

sub str { my $t = $_[0]->type; die "Cast from $t to Str is not supported" }
sub num { my $t = $_[0]->type; die "Cast from $t to Num is not supported" }
sub bool { my $t = $_[0]->type; die "Cast from $t to Bool is not supported" }
sub list { my $t = $_[0]->type; die "Cast from $t to List is not supported" }
sub none { $TestML::Constant::None }

#-----------------------------------------------------------------------------
package TestML::Str;
use TestML::Mo;
extends 'TestML::Object';

sub str { shift }
sub num { TestML::Num->new(
    value => ($_[0]->value =~ /^-?\d+(?:\.\d+)$/ ? ($_[0]->value + 0) : 0),
)}
sub bool {
    length($_[0]->value) ? $TestML::Constant::True : $TestML::Constant::False
}
sub list { TestML::List->new(value => [split //, $_[0]->value]) }

#-----------------------------------------------------------------------------
package TestML::Num;
use TestML::Mo;
extends 'TestML::Object';

sub str { TestML::Str->new(value => $_[0]->value . "") }
sub num { shift }
sub bool { ($_[0]->value != 0) ? $TestML::Constant::True : $TestML::Constant::False }
sub list {
    my $list = [];
    $#{$list} = int($_[0]) -1;
    TestML::List->new(value =>$list);
}

#-----------------------------------------------------------------------------
package TestML::Bool;
use TestML::Mo;
extends 'TestML::Object';

sub str { TestML::Str->new(value => $_[0]->value ? "1" : "") }
sub num { TestML::Num->new(value => $_[0]->value ? 1 : 0) }
sub bool { shift }

#-----------------------------------------------------------------------------
package TestML::List;
use TestML::Mo;
extends 'TestML::Object';
sub list { shift }

#-----------------------------------------------------------------------------
package TestML::None;
use TestML::Mo;
extends 'TestML::Object';

sub str { Str('') }
sub num { Num(0) }
sub bool { $TestML::Constant::False }
sub list { List([]) }

#-----------------------------------------------------------------------------
package TestML::Error;
use TestML::Mo;
extends 'TestML::Object';

#-----------------------------------------------------------------------------
package TestML::Native;
use TestML::Mo;
extends 'TestML::Object';

package TestML::Constant;

our $True = TestML::Bool->new(value => 1);
our $False = TestML::Bool->new(value => 0);
our $None = TestML::None->new;