%{
=head1 NAME

Grammar::DAG::Parser - this module implements the parser for the DAG grammar

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.02';

=head1 DESCRIPTION

TODO

=head1 FUNCTIONS

TODO

=cut
%}

# Saw to emacs we want -*- cperl -*- mode

%token AGOD_ID AGOD_ARROW AGOD_FOUR_DOTS AGOD_PERL AGOD_FINAL AGOD_QUANTIFIER AGOD_ATTRIB AGOD_PRE

%%
dag_file: preamble rules AGOD_FINAL             { +{'%PRE'=>$_[1],'%DAG'=>$_[2],'%TAIL'=>$_[3]} }
         ;

preamble: preamble AGOD_PRE AGOD_ID pre_rule  { unshift @{$_[1]},{$_[3]=>$_[4]}; $_[1] }
        |                                       { +[] }
        ;

pre_rule: list_rec   { @{$_[1]}==1 ? @{$_[1]}[0] : $_[1] }
        | MINI_PERL  { $_[1] }
        ;

rules: rules rule attrs                         { +{%{$_[1]},$_[2]->[0]=>{%{$_[3]},%{$_[2]->[1]}}} }
     | rule attrs                               { +{         $_[1]->[0]=>{%{$_[2]},%{$_[1]->[1]}}} }
     ;

rule: AGOD_ID ';'                               {[$_[1], {'%RHS' => []    }]}
    | AGOD_ID MINI_PERL ';'                     {[$_[1], {'%MONO' => $_[2] }]}
    | AGOD_ID AGOD_ARROW rhs ';'                {[$_[1], {'%RHS' => $_[3] }]}
    | AGOD_ID AGOD_ARROW rhs MINI_PERL ';'      {[$_[1], {'%RHS' => $_[3], '%MONO' => $_[4] }]}
    ;

rhs: rhs quantifier                             { push @{$_[1]}, $_[2]; $_[1] }
   | quantifier                                 {             [ $_[1] ]  }
   ;

quantifier: AGOD_ID AGOD_QUANTIFIER             {+{$_[1] => $_[2]}}
          | AGOD_ID                             {+{$_[1] => 1    }}
          ;

attrs:                                          {+{                 }}
     | attrs attr                               {+{%{$_[1]},%{$_[2]}}}
     ;

attr: AGOD_FOUR_DOTS AGOD_ID list '=' AGOD_PERL { +{$_[2] => { NEEDS=>$_[3], RETURNS=>$_[5] }}}
    | AGOD_FOUR_DOTS AGOD_ID list '&' AGOD_PERL {+{$_[2] => { NEEDS=>$_[3], EXECUTE=>$_[5] }}}
    | AGOD_FOUR_DOTS AGOD_ID list AGOD_ATTRIB AGOD_PERL {+{$_[2] => { NEEDS=>$_[3], ATTRIB=>$_[5] }}}
    | AGOD_FOUR_DOTS AGOD_PERL                  {+{'%BEGIN' => $_[2]}}
    ;

list:                                           { []    }
    | '[' list_rec ']'                          { $_[2] }
    ;

list_rec: AGOD_ID                               { [$_[1]]                     }
        | list_rec ',' AGOD_ID                  { push @{$_[1]}, $_[3]; $_[1] }
        ;
%%

=head2 yylex

Function used to tokenize source code.

=cut

use Regexp::Common qw /balanced/;
our $rt;

sub yylex {
  my $text = shift;

  $text = $rt if defined $rt;
  $text =~ s!^(\s|#.*)*!!;
  my $word = '(\!?(\.\w|\w\d+|\w|<\w+>)+)';
  for ($text) {
    if (/^$word/)                 { $rt = $'; return ('AGOD_ID', $&); }
    #if (/^([\w,]+)/)            { $rt = $'; return ('MY_LIST', $1); }
    if (/^--->/)                  { $rt = $'; return ('AGOD_ARROW', $&); }
    if (/^[*+?]/)                 { $rt = $'; return ('AGOD_QUANTIFIER', $&); }
    if (/^::/)                    { $rt = $'; return ('AGOD_FOUR_DOTS', $&); }
    if (/^(\[|\])/)               { $rt = $'; return ($&, $&); }
    if (/^do\b/)                  { $rt = $'; return ('&','&'); }
    if (/^:=/)                    { $rt = $'; return ('AGOD_ATTRIB', $&); }
    if (/^[,;&=]/)                { $rt = $'; return ($&, $&); }
    if (/^%%(.*)/s)                { $rt = $'; return ('AGOD_FINAL', $1); }
    if (/^%/)                     { $rt = $'; return ('AGOD_PRE', $&); }
    if (/^($RE{balanced}{-parens=>'{}'})/) { $rt = $'; return ('MINI_PERL', $&); }
    if (/^(\{(\n|.)*?\})(\s|\n)*\n(%%|::|\s*($word\s*(--->|;(\s|\n)*($word\s*;(\s|\n)*)*(::|%%))))/) {
      ### WEIRD, but works
      $rt = $4.$';
      return ('AGOD_PERL', $1);
    }
    $rt = $';
    return undef
  }
}

=head2 yyerror

Fuction used to report errors.

=cut

sub yyerror {
	my $msg =shift;
	die ("my error: $msg ($rt)");
}

1;
__END__