package Language::AttributeGrammar;

use 5.006001;
use strict;
use warnings;
no warnings 'uninitialized';

our $VERSION = '0.08';

use Language::AttributeGrammar::Parser;
use Perl6::Attributes;

my $methnum = '0';

sub new {
    my ($class, $options, $grammar) = @_;
    unless (ref $options eq 'HASH') {
        $grammar = $options;
        $options = {};
    }

    my $engine = Language::AttributeGrammar::Parser->new($grammar, $options->{prefix});
    my $meth = '_AG_visit_' . $methnum++;
    $engine->make_visitor($meth);
    
    bless {
        engine => $engine,
        meth   => $meth,
    } => ref $class || $class;
}

sub apply {
    my ($self, $top, $attr, $topattrs) = @_;

    $.engine->evaluate($.meth, $top, $attr, $topattrs);
}

sub annotate {
    my ($self, $top, $topattrs) = @_;
    Language::AttributeGrammar::Annotator->new($.engine->annotate($.meth, $top, $topattrs));
}

package Language::AttributeGrammar::Annotator;

sub new {
    my ($class, $ann) = @_;

    bless {
        ann => $ann,
    } => ref $class || $class;
}

our $AUTOLOAD;
sub AUTOLOAD {
    (my $attr = $AUTOLOAD) =~ s/.*:://;
    return if $attr eq 'DESTROY';

    my ($self, $node) = @_;
    $self->get($node)->get($attr)->get;
}

1;


=head1 NAME

Language::AttributeGrammar - Attribute grammars for doing computations over trees.

=head1 SYNOPSIS

    use Language::AttributeGrammar;

    # Grammar to return a new tree that is just like the old one, except
    # every leaf's value is the value of the minimum leaf.
    
    my $grammar = new Language::AttributeGrammar <<'END_GRAMMAR';

    # find the minimum of a tree from the leaves up
    Leaf:   $/.min = { $<value> }
    Branch: $/.min = { List::Util::min($<left>.min, $<right>.min)) }

    # find the global minimum and propagate it back down the tree
    ROOT:   $/.gmin        = { $/.min }
    Branch: $<left>.gmin   = { $/.gmin }
          | $<right>.gmin) = { $/.gmin }

    # reconstruct the tree with every leaf replaced with the minimum value
    Leaf:   $/.result    = { Leaf->new($/.gmin) }
    Branch: $/.result    = { Branch->new($<left>.result, $<right>.result) }
    
    END_GRAMMAR
    
    # This grammar expects that you define these classes:
    #                Branch (with a ->left and ->right attribute)
    #                Leaf   (with a ->value attribute)

    # Use the grammar
    my $tree = Branch->new( Leaf->new(1), 
                            Branch->new( Leaf->new(2), Leaf->new(3)));
                                       
    # Apply the attribute grammar to the data structure and fetch the result
    my $result = $grammar->apply($tree, 'result');
    
=head1 DESCRIPTION

This module implements simple (for now) Attribute Grammar support for Perl data
structures.  An attribute grammar is a way to specify I<computation> over a
predefined data structure, say, as generated by L<Parse::RecDescent>.  This is
done by associating I<attributes> with the nodes of the data structure.

There are two types of attributes: synthesized and inherited.  Synthesized
attributes propagate bottom-up, that is, they use information from the children
of a node to infer the attribute's value on that node.  Inherited attributes
are the opposite: they use information from a node in the structure to infer
attributes on its chilren.  

In the example above in the synopsis, the C<min> attribute is synthesized,
since it takes the values at the leaves and infers the minimum at a branch.
The C<gmin> (global minimum) attribute is inherited, since it uses C<gmin> that
was computed at the root node and propagates it downward to the leaves.

=head2 Syntax

Some special syntax is used in throughout the definitions, borrowed from the
syntax for Perl 6 grammars.

=over

=item * C<$/>

The current node.

=item * C<$/.attr>

The C<attr> attribute on the current node.

=item * C<< $<foo> >>

The child node named C<foo> of the current node.

=item * C<< $<child>.attr >>

The C<attr> attribute on the child node.

=item * C<< `arbitrary(code)`.attr >>

Execute C<arbitrary(code)> B<IN LIST CONTEXT> and fetch the C<attr> attribute
from each element.  So:

    Foo: $/.bar = { `get_child($/)`.bar }     # WRONG

C<$/.bar> will always be 1 (the number of things C<get_child> returned).  If
you want to do this right, since you are only intending to use one value:

    Foo: $/.bar = { `get_child($/)`.bar[0] }  # okay

Also, the code inside backticks must not refer to any lexical variables or any
attributes.  That is, C<$/> and his children are the only variables you may
refer to (but you may call methods on them, etc.).

=back

The grammar definition is composed of a series of I<semantics> definitions.  An
example semantic definition is:

    Foo: $/.baz        = { $<child>.baz }
       | $<child>.quux = { $/.quux }

This specifies the implementations of the I<synthesized attribute> C<baz> and
the I<inherited attribute> C<quux> for nodes of type Foo.  That is, you can
find the C<baz> attribute of the current node by looking at the baz attribute
of its child, and you can find the C<quux> attribute of any node's child by
looking at the C<quux> attribute of the node itself.

The C<< $<child> >> notation is defined to pretty much do the right thing.
But, in the name of predictability, here are the semantics:

If C<$/> has a method named C<child> (for the attribute C<< $<child> >>), then
that method is called with no arguments to fetch the attribute.  Otherwise, if
C<$/> is a blessed hash, then the module snoops inside the hash and pulls out
the key named "child".  If the hash has no such key, or the object is not a
blessed hash (eg. a blessed array), then we give up.

If your tree has a different convention for extracting child nodes, you may use
the backtick syntax described above:

    Cons:  $/.sum = { `$/->get_child('head')`.sum + `$/->get_child('tail')`.sum }
    Nil:   $/.sum = { 0 }

    Cons:  `$/->get_child('head')`.gsum = { $/.gsum }

In the future I may provide a callback that allows the user to define
the meaning of C<< $<child> >>.

There is one special class name that can go to the left of the colon:
C<ROOT>.  This represents the root of the data structure you were given,
and is used to avoid the common annoyance of creating a Root node
class tha just bootstraps the "real" tree.   So when you say:

    ROOT:  $/.gmin = { $/.min }

That means that when you're at the root of the data structure, the
global minimum is equal to the local minimum.

=head2 Usage

After you have a grammar specification in a string, create a new grammar
object:

    my $grammar = Language::AttributeGrammar->new($grammar_string);

This contains a minimal data structure of the semantics definitions.  The 
constructor also can take an options hash as its first argument:

    my $grammar = Language::AttributeGrammar->new({ prefix => 'Foo::' }, $grammar_string);

The only option at the moment is C<prefix>, which will prepend this
prefix to all the types mentioned in your grammar.  However, if you need
to omit this prefix, name the type in your grammar starting with a
C<::>, and the prefix will not be prepended.

In order to find an attribute on the root node of a data structure, C<apply> it
to the data structure, giving the name of the attribute you wish to find.

    my $attr = $grammar->apply($data, 'attr');

You may set attributes on the root of the data structure by passing a hash.

    my $attr = $grammar->apply($data, 'attr', {
        starting_number => 0,
    });

In order to find attributes on nodes that are lower in the structure, you must
concoct your attribute grammar to propagate that information up the tree
somehow.  Usually this is done using a synthesized attribute that mirrors the
given data structure.

=head1 AUTHOR

Luke Palmer <lrpalmer gmail com>