#============================================================= -*-Perl-*-
#
# Parser.yp
#
# DESCRIPTION
#   Definition of the parser grammar for the Template Toolkit language.
#
# AUTHOR
#   Andy Wardley <abw@wardley.org> 
#
# HISTORY
#   Totally re-written for version 2, based on Doug Steinwand's 
#   implementation which compiles templates to Perl code.  The generated
#   code is _considerably_ faster, more portable and easier to process.
#
# WARNINGS
#   Expect 1 reduce/reduce conflict.  This can safely be ignored.
#   Now also expect 1 shift/reduce conflict, created by adding a rule
#   to 'args' to allow assignments of the form 'foo.bar = baz'.  It
#   should be possible to fix the problem by rewriting some rules, but
#   I'm loathed to hack it up too much right now.  Maybe later.
#
# COPYRIGHT
#   Copyright (C) 1996-2004 Andy Wardley.  All Rights Reserved.
#   Copyright (C) 1998-2004 Canon Research Centre Europe Ltd.
#
#   This module is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
#
#------------------------------------------------------------------------
#
# NOTE: this module is constructed from the parser/Grammar.pm.skel
# file by running the parser/yc script.  You only need to do this if 
# you have modified the grammar in the parser/Parser.yp file and need
# to-recompile it.  See the README in the 'parser' directory for more
# information (sub-directory of the Template distribution).
#
#------------------------------------------------------------------------
#
# $Id$
#
#========================================================================

%right ASSIGN
%right '?' ':'
%left COMMA
%left AND OR
%left NOT
%left CAT
%left DOT
%left CMPOP
%left BINOP
%left '+'
%left '/'
%left DIV
%left MOD
%left TO 
%%

#--------------------------------------------------------------------------
# START AND TOP-LEVEL RULES
#--------------------------------------------------------------------------

template:   block                   { $factory->template($_[1])           }
;

block:      chunks                  { $factory->block($_[1])              }
        |   /* NULL */              { $factory->block()                   }
;

chunks:     chunks chunk            { push(@{$_[1]}, $_[2]) 
                                        if defined $_[2]; $_[1]           }
        |   chunk                   { defined $_[1] ? [ $_[1] ] : [ ]     }
;

chunk:      TEXT                    { $factory->textblock($_[1])          }
        |   statement ';'           { return '' unless $_[1];
                                      $_[0]->location() . $_[1];
                                    }
;

statement:  directive
        |   defblock
        |   anonblock
        |   capture
        |   macro
        |   use       
        |   view       
        |   rawperl
        |   expr                    { $factory->get($_[1])                }
        |   META metadata           { $_[0]->add_metadata($_[2]);         }
        |   /* empty statement */
;

directive:  setlist                 { $factory->set($_[1])                }
        |   atomdir
        |   condition
        |   switch
        |   loop
        |   try
        |   perl
;


#--------------------------------------------------------------------------
# DIRECTIVE RULES
#--------------------------------------------------------------------------

atomexpr:   expr                    { $factory->get($_[1])                }
        |   atomdir
;

atomdir:    GET expr                { $factory->get($_[2])                }
        |   CALL expr               { $factory->call($_[2])               }
        |   SET setlist             { $factory->set($_[2])                }
        |   DEFAULT setlist         { $factory->default($_[2])            }
        |   INSERT nameargs         { $factory->insert($_[2])             }
        |   INCLUDE nameargs        { $factory->include($_[2])            }
        |   PROCESS nameargs        { $factory->process($_[2])            }
        |   THROW nameargs          { $factory->throw($_[2])              }
        |   RETURN                  { $factory->return()                  }
        |   STOP                    { $factory->stop()                    }
        |   CLEAR                   { "\$output = '';";                   }
        |   LAST                    { $_[0]->block_label('last ', ';')    }
        |   NEXT                    { $_[0]->in_block('FOR')
                                        ? $factory->next($_[0]->block_label)
                                        : $_[0]->block_label('next ', ';') }
        |   DEBUG nameargs          { if ($_[2]->[0]->[0] =~ /^'(on|off)'$/) {
                                          $_[0]->{ DEBUG_DIRS } = ($1 eq 'on');
                                          $factory->debug($_[2]);
                                      }
                                      else {
                                          $_[0]->{ DEBUG_DIRS } ? $factory->debug($_[2]) : '';
                                      }
                                    }
        |   wrapper
        |   filter
;

condition:  IF expr ';' 
              block else END        { $factory->if(@_[2, 4, 5])           }
        |   atomexpr IF expr        { $factory->if(@_[3, 1])              }
        |   UNLESS expr ';'
              block else END        { $factory->if("!($_[2])", @_[4, 5])  }
        |   atomexpr UNLESS expr    { $factory->if("!($_[3])", $_[1])     }
;

else:       ELSIF expr ';' 
              block else            { unshift(@{$_[5]}, [ @_[2, 4] ]);
                                      $_[5];                              }
        |   ELSE ';' block          { [ $_[3] ]                           }
        |   /* NULL */              { [ undef ]                           }
;

switch:     SWITCH expr ';' 
              block case END        { $factory->switch(@_[2, 5])          } 
;

case:       CASE term ';' block
              case                  { unshift(@{$_[5]}, [ @_[2, 4] ]); 
                                      $_[5];                              }
        |   CASE DEFAULT ';' block  { [ $_[4] ]                           }
        |   CASE ';' block          { [ $_[3] ]                           }
        |   /* NULL */              { [ undef ]                           }
;

loop:       FOR loopvar ';'         { $_[0]->enter_block('FOR')           }
                block END           { $factory->foreach(@{$_[2]}, $_[5], $_[0]->leave_block)  }
        |   atomexpr FOR loopvar    { $factory->foreach(@{$_[3]}, $_[1])  }
        |   WHILE expr ';'          { $_[0]->enter_block('WHILE')         }
              block END             { $factory->while(@_[2, 5], $_[0]->leave_block) }
        |   atomexpr WHILE expr     { $factory->while(@_[3, 1]) }
;

loopvar:    IDENT ASSIGN term args  { [ @_[1, 3, 4] ]                     }
        |   IDENT IN term args      { [ @_[1, 3, 4] ]                     }
        |   term args               { [ 0, @_[1, 2] ]                     }
;

wrapper:    WRAPPER nameargs ';'
              block END             { $factory->wrapper(@_[2, 4])         }
        |   atomexpr 
              WRAPPER nameargs      { $factory->wrapper(@_[3, 1])         }
;

try:        TRY ';' 
              block final END       { $factory->try(@_[3, 4])             }
;

final:      CATCH filename ';'  
              block final           { unshift(@{$_[5]}, [ @_[2,4] ]);
                                      $_[5];                              }
        |   CATCH DEFAULT ';'
              block final           { unshift(@{$_[5]}, [ undef, $_[4] ]);
                                      $_[5];                              }
        |   CATCH ';'
              block final           { unshift(@{$_[4]}, [ undef, $_[3] ]);
                                      $_[4];                              }
        |    FINAL ';' block        { [ $_[3] ]                           }
        |   /* NULL */              { [ 0 ] } # no final
;

use:        USE lnameargs           { $factory->use($_[2])                }
;

view:       VIEW nameargs ';'       { $_[0]->push_defblock();             }
              block END             { $factory->view(@_[2,5], 
                                                     $_[0]->pop_defblock) }
;

perl:       PERL ';'                { ${$_[0]->{ INPERL }}++;             }
              block END             { ${$_[0]->{ INPERL }}--;
                                      $_[0]->{ EVAL_PERL } 
                                      ? $factory->perl($_[4])             
                                      : $factory->no_perl();              }
;

rawperl:    RAWPERL                 { ${$_[0]->{ INPERL }}++; 
                                      $rawstart = ${$_[0]->{'LINE'}};     }
            ';' TEXT END            { ${$_[0]->{ INPERL }}--;
                                      $_[0]->{ EVAL_PERL } 
                                      ? $factory->rawperl($_[4], $rawstart)
                                      : $factory->no_perl();              }
;

filter:     FILTER lnameargs ';' 
              block END             { $factory->filter(@_[2,4])           }
        |   atomexpr FILTER 
              lnameargs             { $factory->filter(@_[3,1])           }
;

defblock:   defblockname 
            blockargs ';' 
            template END            { my $name = join('/', @{ $_[0]->{ DEFBLOCKS } });
                                      pop(@{ $_[0]->{ DEFBLOCKS } });
                                      $_[0]->define_block($name, $_[4]); 
                                      undef
                                    }
;

defblockname: BLOCK blockname       { push(@{ $_[0]->{ DEFBLOCKS } }, $_[2]);
                                      $_[2];
                                    }
;

blockname:  filename 
        |   LITERAL                 { $_[1] =~ s/^'(.*)'$/$1/; $_[1]      }
;

blockargs:  metadata 
        |   /* NULL */
;

anonblock:  BLOCK blockargs ';' block END           
                                    { local $" = ', ';
                                      print STDERR "experimental block args: [@{ $_[2] }]\n"
                                          if $_[2];
                                      $factory->anon_block($_[4])         }
;

capture:    ident ASSIGN mdir       { $factory->capture(@_[1, 3])         }
;

macro:      MACRO IDENT '(' margs ')'
                mdir                { $factory->macro(@_[2, 6, 4])        }
        |   MACRO IDENT mdir        { $factory->macro(@_[2, 3])           }
;

mdir:       directive
        |   BLOCK ';' block END     { $_[3]                               }
;

margs:      margs IDENT             { push(@{$_[1]}, $_[2]); $_[1]        }
        |   margs COMMA             { $_[1]                               }
        |   IDENT                   { [ $_[1] ]                           }
;

metadata:   metadata meta           { push(@{$_[1]}, @{$_[2]}); $_[1]     }
        |   metadata COMMA
        |   meta
;

meta:       IDENT ASSIGN LITERAL       { for ($_[3]) { s/^'//; s/'$//; 
                                                       s/\\'/'/g  }; 
                                         [ @_[1,3] ] }
        |   IDENT ASSIGN '"' TEXT '"'  { [ @_[1,4] ] } 
        |   IDENT ASSIGN NUMBER        { [ @_[1,3] ] }
;


#--------------------------------------------------------------------------
# FUNDAMENTAL ELEMENT RULES
#--------------------------------------------------------------------------

term:       lterm
        |   sterm
;

lterm:      '[' list  ']'           { "[ $_[2] ]"                         }
        |   '[' range ']'           { "[ $_[2] ]"                         }
        |   '['       ']'           { "[ ]"                               }
        |   '{' hash  '}'           { "{ $_[2]  }"                        }
;

sterm:      ident                   { $factory->ident($_[1])              }
        |   REF ident               { $factory->identref($_[2])           }
        |   '"' quoted '"'          { $factory->quoted($_[2])             }
        |   LITERAL
        |   NUMBER
;

list:       list term               { "$_[1], $_[2]"                      }
        |   list COMMA
        |   term
;

range:      sterm TO sterm          { $_[1] . '..' . $_[3]                }
;


hash:       params
        |   /* NULL */              { "" }
;

params:     params param            { "$_[1], $_[2]"                      }
        |   params COMMA
        |   param
;

param:      LITERAL ASSIGN expr     { "$_[1] => $_[3]"                    }
        |   item ASSIGN expr        { "$_[1] => $_[3]"                    }
;

ident:      ident DOT node          { push(@{$_[1]}, @{$_[3]}); $_[1]     }
        |   ident DOT NUMBER        { push(@{$_[1]}, 
                                           map {($_, 0)} split(/\./, $_[3]));
                                      $_[1];                              }
        |   node     
;

node:       item                    { [ $_[1], 0 ]                        }
        |   item '(' args ')'       { [ $_[1], $factory->args($_[3]) ]    }
;

item:       IDENT                   { "'$_[1]'"                           }
        |   '${' sterm '}'          { $_[2]                               }
        |   '$' IDENT               { $_[0]->{ V1DOLLAR }
                                       ? "'$_[2]'" 
                                       : $factory->ident(["'$_[2]'", 0])  }
;

expr:       expr BINOP expr         { "$_[1] $_[2] $_[3]"                 }
        |   expr '/' expr           { "$_[1] $_[2] $_[3]"                 }
        |   expr '+' expr           { "$_[1] $_[2] $_[3]"                 }
        |   expr DIV expr           { "int($_[1] / $_[3])"                }
        |   expr MOD expr           { "$_[1] % $_[3]"                     }
        |   expr CMPOP expr         { "$_[1] $CMPOP{ $_[2] } $_[3]"       }
        |   expr CAT expr           { "$_[1]  . $_[3]"                    }
        |   expr AND expr           { "$_[1] && $_[3]"                    }
        |   expr OR expr            { "$_[1] || $_[3]"                    }
        |   NOT expr                { "! $_[2]"                           }
        |   expr '?' expr ':' expr  { "$_[1] ? $_[3] : $_[5]"             }
        |   '(' assign ')'          { $factory->assign(@{$_[2]})          }
        |   '(' expr ')'            { "($_[2])"                           }
        |   term                
;

setlist:    setlist assign          { push(@{$_[1]}, @{$_[2]}); $_[1]     }
        |   setlist COMMA
        |   assign
;


assign:     ident ASSIGN expr       { [ $_[1], $_[3] ]                    }
        |   LITERAL ASSIGN expr     { [ @_[1,3] ]                         }
;

# The 'args' production constructs a list of named and positional 
# parameters.  Named parameters are stored in a list in element 0 
# of the args list.  Remaining elements contain positional parameters

args:       args expr               { push(@{$_[1]}, $_[2]); $_[1]        }
        |   args param              { push(@{$_[1]->[0]}, $_[2]); $_[1]   }
        |   args ident ASSIGN expr  { push(@{$_[1]->[0]}, "'', " . 
                                      $factory->assign(@_[2,4])); $_[1]  }
        |   args COMMA              { $_[1]                               }
        |   /* init */              { [ [ ] ]                             }
;


# These are special case parameters used by INCLUDE, PROCESS, etc., which 
# interpret barewords as quoted strings rather than variable identifiers;
# a leading '$' is used to explicitly specify a variable.  It permits '/',
# '.' and '::' characters, allowing it to be used to specify filenames, etc.
# without requiring quoting.

lnameargs:  lvalue ASSIGN nameargs  { push(@{$_[3]}, $_[1]); $_[3]        }
        |   nameargs
;

lvalue:     item
        |   '"' quoted '"'          { $factory->quoted($_[2])             }
        |   LITERAL
;

nameargs:   '$' ident args          { [ [$factory->ident($_[2])], $_[3] ]   }
        |   names args              { [ @_[1,2] ] }
        |   names '(' args ')'      { [ @_[1,3] ] }
;

names:      names '+' name          { push(@{$_[1]}, $_[3]); $_[1] }
        |   name                    { [ $_[1] ]                    }
;

name:       '"' quoted '"'          { $factory->quoted($_[2])  }
        |   filename                { "'$_[1]'" }
        |    LITERAL
;

filename:   filename DOT filepart   { "$_[1].$_[3]" }
        |   filepart
;

filepart: FILENAME | IDENT | NUMBER 
;


# The 'quoted' production builds a list of 'quotable' items that might
# appear in a quoted string, namely text and identifiers.  The lexer
# adds an explicit ';' after each directive it finds to help the
# parser identify directive/text boundaries; we're not interested in
# them here so we can simply accept and ignore by returning undef

quoted:     quoted quotable         { push(@{$_[1]}, $_[2]) 
                                          if defined $_[2]; $_[1]         }
        |   /* NULL */              { [ ]                                 }
;

quotable:   ident                   { $factory->ident($_[1])              }
        |   TEXT                    { $factory->text($_[1])               }
        |   ';'                     { undef                               }
;


%%