use strict;
use warnings;

use Test::More tests => 14;
use Test::Exception;

my $m; BEGIN { use_ok($m = 'Language::AttributeGrammar') }

can_ok($m, "new");
can_ok($m, "apply");

sub mkg { $m->new(shift) }
sub mko { my $c = shift; bless { @_ }, $c }
sub apply { mkg(shift)->apply(@_) }

{
    my $g = mkg('Foo: $/.gorch = { 42 }');

    my $r;
    lives_ok { $r = $g->apply(mko("Foo"), 'gorch') } "ok to access valid attribute";
    is($r, 42, "the attribute's value");

    dies_ok { $r->apply(mko("Foo"), 'swick') } "fatal to access invalid attribute";
}

{
    my $g = mkg(<<'EOG');
Foo: $/.gorch = { 42 }
   | $/.bar   = { $/.gorch / 2 }
EOG

    is($g->apply(mko("Foo"), 'bar'), 21, "dependent attributes on the same node");
}

{
    my $g = mkg(<<'EOG');
Foo: $/.value = { 3 * $<bar>.value }
Bar: $/.value = { 4 }
EOG

    is($g->apply(mko("Foo", bar => mko("Bar")), 'value'), 12, 
        "one level of synthesized attributes");
}


{
    my $o = mko(Foo => child => mko(Foo => child => mko(Foo => child => mko('Bar'))));
    my $g = mkg(<<'EOG');
Foo: $/.value = { 3 * $<child>.value }
Bar: $/.value = { 4 }
EOG

    is($g->apply($o, 'value'), 3 * 3 * 3 * 4, "N levels of synthesized attributes");
}

{
    my $g = mkg(<<'EOG');
Foo: $<bar>.parent_value = { 3 }
   | $/.value        = { $<bar>.value }
Bar: $/.value        = { 4 * $/.parent_value }
EOG

    is($g->apply(mko("Foo", bar => mko("Bar")), 'value'), 12, 
        "one level of inherited attributes");
}

{
    my $o = mko(Root => child => mko(Foo => child => mko(Foo => child => mko(Foo => child => mko("Bar")))));
    my $g = mkg(<<'EOG');
Root: $<child>.parent_value = { 1 }
    | $/.value = { $<child>.value }

Foo: $<child>.parent_value = { 3 * $/.parent_value }
   | $/.value = { $<child>.value }

Bar: $/.value = { 4 * $/.parent_value }
EOG

    is($g->apply($o, 'value'), 3 * 3 * 3 * 4, "N levels of inherited attributes");
}

{
    my $g = mkg(<<'EOG');
ROOT: $/.foo = { 5 }
Foo: $<child>.bar = { $/.foo }
   | $/.bah = { $<child>.bah }
Bar: $/.bah = { $/.bar + 10 }
EOG
    is($g->apply(mko(Foo => child => mko('Bar')), 'bah'), 15, "ROOT inherits");
}

TODO: {
    local $TODO = 'I suppose ROOT should override if there is an overlap';
    my $g = mkg(<<'EOG');
ROOT: $/.foo = { 5 }
Foo: $/.foo = { $<child>.bar }
Bar: $/.bar = { 10 }
EOG
    eval {
        my $r = $g->apply(mko(Foo => child => mko('Bar')), 'foo');
        is($r, 5, "definition under ROOT overrides definition over class"); 1;
    } or ok(0, "definition under ROOT overrides definition over class");
}

{
    sub Foo::getchild {
        my ($foo) = @_;
        $foo->{child}
    }
    my $g = mkg(<<'EOG');
Foo: $/.foo = { `$/->getchild`.foo[0] }
Bar: $/.foo = { $<value> }
EOG
    my $r = $g->apply(mko(Foo => child => mko(Foo => child => mko(Bar => value => 42))), 'foo');
    is($r, 42, 'backticks');
}

# vim: ft=perl :