# See bottom of file for copyright and license details

=pod

---+ package TWiki::Infix::Parser

A simple stack-based parser that parses infix expressions with nonary,
unary and binary operators specified using an operator table.

Escapes are supported in strings, using backslash.

=cut

package TWiki::Infix::Parser;

use strict;
use Assert;
use Error qw( :try );
require TWiki::Infix::Error;
require TWiki::Infix::Node;

# Set to 1 for debug
sub MONITOR_PARSER { 0 };

=pod

---++ new($client_class, \%options) -> parser object

Creates a new infix parser. Operators must be added for it to be useful.

The tokeniser matches tokens in the following order: operators,
quotes (" and '), numbers, words, brackets. If you have any overlaps (e.g.
an operator '<' and a bracket operator '<<') then the first choice
will match.

=$client_class= needs to be the _name_ of a _package_ that supports the
following two functions:
   * =newLeaf($val, $type)= - create a terminal. $type will be:
      1 if the terminal matched the =words= specification (see below).
      2 if it is a number matched the =numbers= specification (see below)
      3 if it is a quoted string
   * =newNode($op, @params) - create a new operator node. @params
     is a variable-length list of parameters, left to right. $op
     is a reference to the operator hash in the \@opers list.
These functions should throw Error::Simple in the event of errors.
TWiki::Infix::Node is such a class, ripe for subclassing.

The remaining parameters are named, and specify options that affect the
behaviour of the parser:
   1 =words=>qr//= - should be an RE specifying legal words (unquoted
     terminals that are not operators i.e. names and numbers). By default
     this is =\w+=.
     It's ok if operator names match this RE; operators always have precedence
     over atoms.
   2 =numbers=>qr//= - should be an RE specifying legal numbers (unquoted
     terminals that are not operators or words). By default
     this is =qr/[+-]?(?:\d+\.\d+|\d+\.|\.\d+|\d+)(?:[eE][+-]?\d+)?/=,
     which matches integers and floating-point numbers. Number
     matching always takes precedence over word matching (i.e. "1xy" will
     be parsed as a number followed by a word. A typical usage of this option
     is when you only want to recognise integers, in which case you would set
     this to =numbers => qr/\d+/=.

=cut

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

    my $this = bless({
        client_class => $options->{nodeClass},
        operators => [],
        initialised => 0,
    }, $class);

    $this->{numbers} = defined( $options->{numbers} ) ? $options->{numbers} :
      qr/[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?/;

    $this->{words} = defined( $options->{words} ) ? $options->{words} :
      qr/\w+/;

    return $this;
}

=pod

---++ ObjectMethod addOperator(%oper)
Add an operator to the parser.

=%oper= is a hash, containing the following fields:
   * =name= - operator string
   * =prec= - operator precedence, positive non-zero integer.
     Larger number => higher precedence.
   * =arity= - set to 1 if this operator is unary, 2 for binary. Arity 0
     is legal, should you ever need it.
   * =close= - used with bracket operators. =name= should be the open
     bracket string, and =close= the close bracket. The existance of =close=
     marks this as a bracket operator.
   * =casematters== - indicates that the parser should check case in the
     operator name (i.e. treat 'AND' and 'and' as different).
     By default operators are case insensitive. *Note* that operator
     names must be caselessly unique i.e. you can't define 'AND' and 'and'
     as different operators in the same parser. Does not affect the
     interpretation of non-operator terminals (names).
Other fields in the hash can be used for other purposes; the parse tree
generated by this parser will point to the hashes passed to this function.

Field names in the hash starting with =InfixParser_= are reserved for use
by the parser.

=cut

sub addOperator {
    my $this = shift;
    push( @{$this->{operators}}, { @_ } );
    $this->{initialised} = 0;
}

# Initialise on demand before a first parse
sub _initialise {
    my $this = shift;

    return if $this->{initialised};

    # Build operator lists
    my @stdOpsRE;
    my @bracketOpsRE;
    foreach my $op (@{$this->{operators}}) {
        # Build a RE for the operator. Note that operators
        # that end in \w are terminated with \b
        my $opre = quotemeta($op->{name});
        $opre .= ($op->{name} =~ /\w$/) ? '\b' : '';
        if ($op->{casematters}) {
            $op->{InfixParser_RE} = qr/$opre/;
        } else {
            $op->{InfixParser_RE} = qr/$opre/i;
        }
        if (defined($op->{close})) {
            # bracket op
            $this->{bracket_ops}->{lc($op->{name})} = $op;

            $opre = quotemeta($op->{close});
            $opre .= ($op->{close} =~ /\w$/) ? '\b' : '';
            if ($op->{casematters}) {
                $op->{InfixParser_closeRE} = qr/$opre/;
            } else {
                $op->{InfixParser_closeRE} = qr/$opre/i;
            }
            push(@bracketOpsRE, $op->{InfixParser_RE});
        } else {
            $this->{standard_ops}->{lc($op->{name})} = $op;
            push(@stdOpsRE, $op->{InfixParser_RE});
        }
    }

    # Build regular expression of all standard operators.
    $this->{standard_op_REs} = join('|', @stdOpsRE);

    # and repeat for bracket operators
    $this->{bracket_op_REs} = join('|', @bracketOpsRE);

    $this->{initialised} = 1;
}

=pod

---++ ObjectMethod parse($string) -> $parseTree
Parses =$string=, calling =newLeaf= and =newNode= in the client class
as necessary to create a parse tree. Returns the result of calling =newNode=
on the root of the parse.

Throws TWiki::Infix::Error in the event of parse errors.

=cut

sub parse {
    my ($this, $expr) = @_;
    my $data = $expr;
    $this->_initialise();
    return _parse( $this, $expr, \$data );
}

# Simple stack parser, after Knuth
sub _parse {
    my( $this, $expr, $input, $term ) = @_;

    throw TWiki::Infix::Error("Empty expression")
      unless $expr && $expr =~ /\S/;

    my @opers = ();
    my @opands = ();

    $input ||= \$expr;

    print STDERR "Parse: $$input\n" if MONITOR_PARSER;
    try {
        while ($$input =~ /\S/) {
            if ($$input =~ s/^\s*($this->{standard_op_REs})//) {
                my $opname = $1;
                print STDERR "Tok: op '$opname'\n" if MONITOR_PARSER;
                my $op = $this->{standard_ops}->{lc($opname)};
                ASSERT($op, $opname) if DEBUG;
                _apply($this, $op->{prec}, \@opers, \@opands);
                push(@opers, $op);
            } elsif ($$input =~ s/^\s*(['"])(|.*?[^\\])\1//) {
                print STDERR "Tok: qs '$1'\n" if MONITOR_PARSER;
                my $val = $2;
                push( @opands, $this->{client_class}->newLeaf(
                    $val, $TWiki::Infix::Node::STRING));
            } elsif ($$input =~ s/^\s*($this->{numbers})//) {
                print STDERR "Tok: number '$1'\n" if MONITOR_PARSER;
                my $val = $1;
                push( @opands, $this->{client_class}->newLeaf(
                    $val, $TWiki::Infix::Node::NUMBER));
            } elsif ($$input =~ s/^\s*($this->{words})//) {
                print STDERR "Tok: word '$1'\n" if MONITOR_PARSER;
                my $val = $1;
                push( @opands, $this->{client_class}->newLeaf(
                    $val, $TWiki::Infix::Node::NAME));
            } elsif ($$input =~ s/^\s*($this->{bracket_op_REs})//) {
                my $opname = $1;
                print STDERR "Tok: open bracket $opname\n" if MONITOR_PARSER;
                my $op = $this->{bracket_ops}->{lc($opname)};
                ASSERT($op) if DEBUG;
                _apply($this, $op->{prec}, \@opers, \@opands);
                push(@opers, $op);
                push(@opands,
                     $this->_parse($expr, $input, $op->{InfixParser_closeRE}));
            } elsif (defined($term) && $$input =~ s/^\s*$term//) {
                print STDERR "Tok: close bracket $term\n" if MONITOR_PARSER;
                last;
            } else {
                throw TWiki::Infix::Error(
                    'Syntax error', $expr, $$input);
            }
        }
        _apply($this, 0, \@opers, \@opands);
    } catch Error::Simple with {
        # Catch errors thrown during the tree building process
        throw TWiki::Infix::Error(shift, $expr, $$input);
    };
    throw TWiki::Infix::Error(
        'Missing operator', $expr, $$input) unless scalar(@opands) == 1;
    throw TWiki::Infix::Error(
        'Excess operators ('.
          join(' ', map { $_->{name} } @opers).')', $expr, $$input)
      if scalar(@opers);
    my $result =  pop(@opands);
    print STDERR "Return ".$result->stringify()."\n" if MONITOR_PARSER;
    return $result;
}

# Apply ops on the stack while their precedence is higher than $prec
# For each operator on the stack with precedence >= $prec, pop the
# required number of operands, construct a new parse node and push
# the node back onto the operand stack.
sub _apply {
    my ($this, $prec, $opers, $opands) = @_;

    while( scalar( @$opers ) && $opers->[-1]->{prec} >= $prec &&
             scalar( @$opands ) >= $opers->[-1]->{arity} ) {
        my $op = pop( @$opers );
        my $arity = $op->{arity};
        my @prams;
        while ($arity--) {
            unshift(@prams, pop(@$opands));
            # Should never get thrown, but just in case...
            throw TWiki::Infix::Error("Missing operand to '$op->{name}'")
              unless $prams[0];
        }
        if (MONITOR_PARSER) {
            print STDERR "Apply $op->{name}(".
              join(', ', map { $_->stringify() } @prams) .")\n";
        }
        push(@$opands, $this->{client_class}->newNode($op, @prams));
    }
}

1;

__DATA__

Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/

Copyright (C) 2005-2007 TWiki Contributors. All Rights Reserved.
TWiki Contributors are listed in the AUTHORS file in the root of
this distribution. NOTE: Please extend that file, not this notice.

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version. For
more details read LICENSE in the root of this distribution.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

As per the GPL, removal of this notice is prohibited.

Author: Crawford Currie http://c-dot.co.uk
