The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
%{
=head1 NAME

Biblio::Thesaurus::ModRewrite::Parser - this module implements the parser
for OML programs

=head1 VERSION

Version 0.02

=cut

our $VERSION = '0.03';

my $File;
my $t;
### Reg exp for blocks

my $bl0 = qr((?:\\[{}]|[^{}])*);
my $bl1 = qr(\{$bl0\});
my $bl2 = qr(\{$bl0(?:$bl1*$bl0)*\});
my $bl3 = qr(\{$bl0(?:$bl2*$bl0)*\});
my $bl4 = qr(\{$bl0(?:$bl3*$bl0)*\});
my $blmidle = qr($bl0(?:$bl4*$bl0)*);



=head1 DESCRIPTION

This module implements the parser used in Biblio::Thesaurus::ModRewrite
to execute programs written in OML. OML is a domain specific language
to describe operations to execut eon ontologies.

=head1 FUNCTIONS

=cut

=head2 new

Create a new object.

=cut
%}

%%

program : statement_list { +{ program=>$_[1] } }
        ;

statement_list : statement_list statement DOT
           {
             my $n = keys %{$_[1]};
             +{ %{$_[1]}, $n=>$_[2]}
           }
           | { +{} }
           ;

statement : cond_block ARROW action_block { +{cond=>$_[1],action=>$_[3]} }
          | DO ARROW action_block { +{cond=>'true',action=>$_[3]} }
          ;

cond_block : token
           | token oper cond_block { +{$_[2] => [$_[1],$_[3]]} }
           ;

token: term relation term { [ $_[1], $_[2], $_[3] ]  }
     | TERM OPEN term CLOSE { +{'term'=>$_[3]} }
     | REL OPEN relation CLOSE { +{'rel'=>$_[3]} }
     ;

term : STRING { +{'term'=>$_[1]} }
     | VAR { +{'var'=>$_[1]} }
     ;

relation : STRING { +{'relation'=>$_[1]} }
         | VAR { +{'var',$_[1]} }
         ;

oper : AND { 'and' }
     | OR { 'or' }
     ;

action_block : action_list
             ;

action_list : action_list action
               {
                 my $n = keys %{$_[1]};
                 +{ %{$_[1]}, $n=>$_[2] }
               }
            | { +{} }
            ;

action : ACTION OPEN token CLOSE { +{ $_[1] => $_[3] } }
       | SUB CODE { +{ $_[1] => $_[2] } }
       ;

%%

=head2 lex

Function used to tokenize source code.

=cut

sub lex {
    for ($File) {
        s!^\s+!!;
        s!^\#.*?\n!!;
        ($_ eq '')    and return ('',undef);

        s!^(\=\>)!!    and return('ARROW',$1);
        s!^(and|\&\&|∧)!!i    and return('AND',$1);
        s!^(or|\|\||∨)!!i    and return('OR',$1);
        s!^(not|\!)!!i    and return('NOT',$1);
        s!^(do|begin|end)!!i    and return('DO',$1);
        s!^(\=\>|⇒)!!    and return('ARROW',$1);
        s!^(\:)!!    and return('COLON',$1);
        s!^(\()!!    and return('OPEN',$1);
        s!^(\))!!    and return('CLOSE',$1);
        s!^(\,)!!    and return('COMMA',$1);
        s!^(\.)!!    and return('DOT',$1);
        s!^(sub)!!    and return('SUB',$1);
        #s!^\{(.*)\}!!s    and print "|$1|\n" and return('CODE',$1);
        #s!^\{([^{}]*(\{[^{}]*\}[^{}]*)*)\}!!s and return('CODE',$1);
        s!^\{($blmidle)\}!!s and return('CODE',$1);

        s!^(term)!!    and return('TERM',$1);
        s!^(rel)!!    and return('REL',$1);
        s!^(add|del)!!    and return('ACTION',$1);
        if (s!^(\w+|\'.*?\'|\".*?\")!!) {
            my $zbr = $1;
            $zbr =~ s/\'|\"//g;
            return('STRING',$zbr);
        }
        s!^\$([a-z]+)!!    and return('VAR',$1);
    }
}

=head2 yyerror

Function used to report errors.

=cut

sub yyerror {
  if ($_[0]->YYCurtok) {
      printf STDERR ('Error: a "%s" (%s) was found where %s was expected'."\n",
         $_[0]->YYCurtok, $_[0]->YYCurval, $_[0]->YYExpect)
  }
  else { print  STDERR "Expecting one of ",join(", ",$_[0]->YYExpect),"\n";
  }
}

=head2 init_lex

Function used to initialize everything we need.

=cut

sub init_lex {
    my $self = shift;
    $File = shift;

    local $/;
    undef $/;
    #$File = <>
}

=head1 AUTHOR

Nuno Carvalho, C<< <smash@cpan.org> >>

J.Joao Almeida, C<< <jj@di.uminho.pt> >>

Alberto Simoes, C<< <albie@alfarrabio.di.uminho.pt> >>

=head1 COPYRIGHT & LICENSE

Copyright 2008 Nuno Carvalho, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

# vim: set filetype=perl