# Copyright (c) 2005  Joshua Hoblitt
#
# $Id: config_grammar.txt,v 1.8 2006-11-04 01:25:32 jhoblitt Exp $

{
    use strict;

    use Carp qw( carp );

    our @scope_stack;
}

startrule: grammar eofile
    { $item{grammar} }

grammar:
    statement(s)
        {
            $thisparser->{local} = pop @scope_stack;
            [ grep $_->{class} !~ /comment_line/, @{$item[1]} ];
        }

statement:
    scalar
    | vector
    | comment_line
    | typedef
    | metadata
    | typedef_declare
    | multi_declare
    | time
    | <error:unmatched statement: $text>

scalar:
    <skip:'[ \t\r]*'> name type <matchrule:$item{type}> comment(?) "\n"
        {
            $thisparser->{local}{name}{ $item{name} }++
                unless defined $thisparser->{local}{name}{ $item{name} };

            $return = {
                class   => 'scalar',
                name    => $item{name},
                type    => $item{type},
                value   => $item[4],
            };

            $return->{comment} = $item{'comment(?)'}[0]
                if $item{'comment(?)'}[0];

            if ( defined $thisparser->{local}{name}{ $item{name} } ) {
                $return->{multi}++
                    if $thisparser->{local}{name}{ $item{name} } =~ /MULTI/;
            } else {
                $thisparser->{local}{name}{ $item{name} }++;
            }
        }

vector:
     <skip:'[ \t\r]*'> vname vtype vvalue[ $item{vtype} ] comment(?) "\n"
        {
            $thisparser->{local}{name}{ $item{vname} }++
                unless defined $thisparser->{local}{name}{ $item{vname} };

            $return = {
                class   => 'vector',
                name    => $item{vname},
                type    => $item{vtype},
                value   => $item{vvalue},
                comment => $item{comment}
            };

            $return->{comment} = $item{'comment(?)'}[0]
                if $item{'comment(?)'}[0];
        }

multi_declare:
    <skip:'[ \t\r]*'> name /MULTI/i <commit> comment(?) "\n"
        {
            if ( ! defined $thisparser->{local}{name}{ $item{name} } ) {
                $thisparser->{local}{name}{ $item{name} } = "MULTI";
                $return = { class   => 'comment_line' };
            } else {
                $return = undef;
            }
        }
    | <error?:redefinition of MULTI> <reject>

metadata:
    metadata_name 
    { push @scope_stack, $thisparser->{local}; $thisparser->{local} = {} }
    grammar
    metadata_end
        {
            my $text = $item[2];
            
            if ( defined( $text ) ) {
                $return = {
                    class   => 'metadata',
                    name    => $item{metadata_name},
                    value   => $item{grammar},
                };
            } else {
                $return = undef;
            }

            if ( defined $thisparser->{local}{name}{ $item{metadata_name} } ) {
                $return->{multi}++
                    if $thisparser->{local}{name}{ $item{metadata_name} } =~ /MULTI/;
            } else {
                $thisparser->{local}{name}{ $item{metadata_name} }++;
            }
        } 
    | metadata_name <commit> comment_line(s?) metadata_end
        {
            $return = {
                class   => 'metadata',
                name    => $item{metadata_name},
                value   => [],
            };

            if ( defined $thisparser->{local}{name}{ $item{metadata_name} } ) {
                $return->{multi}++
                    if $thisparser->{local}{name}{ $item{metadata_name} } =~ /MULTI/;
            } else {
                $thisparser->{local}{name}{ $item{metadata_name} }++;
            }
        } 
    | <error?:bad METADATA syntax: $text> <reject>

comment_line:
    <skip:'[ \t\r]*'> comment(?) "\n"
        {{ class   => 'comment_line' }}

time:
    <skip:'[ \t\r]*'> name ttype <matchrule:$item{ttype}> comment(?) "\n"
        {
            use DateTime::Format::ISO8601;

            $return = {
                class   => 'time',
                name    => $item{name},
                type    => $item{ttype},
                value   => $item[4],
            };

            $return->{comment} = $item{'comment(?)'}[0]
                if $item{'comment(?)'}[0];

            if ( defined $thisparser->{local}{name}{ $item{name} } ) {
                $return->{multi}++
                    if $thisparser->{local}{name}{ $item{name} } =~ /MULTI/;
            } else {
                $thisparser->{local}{name}{ $item{name} }++;
            }
        }

typedef_declare:
    <skip:'[ \t\r]*'> 'TYPE' <commit> name name(s) comment(?) "\n"
        {
            if (defined $thisparser->{local}{typedef}{ $item{name} }) {
                carp "refinition of TYPE $item{name}";    
                $return = undef;
            } else {

                my $type = {
                    class   => 'typedef_declare',
                    name    => $item{name},
                    fields  => $item{'name(s)'},
                    length  => scalar @{ $item{'name(s)'} },
                };

                $thisparser->{local}{typedef}{ $item{name} } = $type;

                # don't return anything in the parse tree
                $return = { class => 'comment_line' };
            }
        }
    | <error?:redefinition of TYPE> <reject>

typedef:
    <skip:'[ \t\r]*'> name typedef_type <commit> word(s) comment(?) "\n"
        {
            my $type = $thisparser->{local}{typedef}{ $item{typedef_type} };

            unless ( scalar @{ $item{'word(s)'} } == $type->{length} ) {
                my $expect = $type->{length};
                my $got = scalar @{ $item{'word(s)'} };
                carp "\"$item{name} $item{typedef_type}\""
                    . " does not have enough fields, epected: $expect, got: $got";
                $return = undef;
            } else {
                my @md;
                my $i = 0;
                foreach my $name ( @{ $type->{fields} } ) {
                    push @md, {
                        name    => $name,
                        class   => 'scalar',
                        type    => 'STR',
                        value   => $item{'word(s)'}[$i],
                    };

                    $i++;
                }

                $return = {
                    class   => 'metadata',
                    name    => $item{name},
                    value   => \@md,
                };

                if ( defined $thisparser->{local}{name}{ $item{name} } ) {
                    $return->{multi}++
                        if $thisparser->{local}{name}{ $item{name} } =~ /MULTI/;
                } else {
                    $thisparser->{local}{name}{ $item{name} }++;
                }
            }

        }
    | <error?:'TYPE' does not have enough parameters: $text> <reject>


typedef_type: name
        {
            if ( ! defined $thisparser->{local}{typedef}{ $item{name} } ) {
                $return = undef;
            } else {
                $return = $item{name};
            }
        }

metadata_name:
    <skip:'[ \t\r]*'> name /METADATA/i comment(?) "\n"
        { $item{name} } 
    
metadata_end:
     <skip:'[ \t\r]*'> /END/i comment(?) "\n"

comment:
    '#' to_end_of_line
        { $item{to_end_of_line} }

vname:
    '@' name
        { $item{name} }

name:
    /[a-z][.\w-]*/i
        {
            if ( $item[1] =~ /^(METADATA|END|TYPE)$/i ) {
                $return = undef;
            } else {
                $return = $item[1];
            }
        }

# 'STR' seems to be the most common type, trying to match it first is a simple
# optimization.
type: 
    'STR'
    | 'STRING'
    | vtype

vtype: 
    'S8'
    | 'S16'
    | 'S32'
    | 'S64'
    | 'U8' 
    | 'U16'
    | 'U32'
    | 'U64'
    | 'F32'
    | 'F64'
    | 'C32'
    | 'C64'
    | 'BOOL'

ttype:
    'UTC'
    | 'UT1'
    | 'TAI'
    | 'TT'

S8: int
S16: int
S32: int
S64: int
U8 : int
U16: int
U32: int
U64: int
F32: float
F64: float
C32: float
C64: float
BOOL: bool
STR: string
STRING: string

vvalue:
    _vvalue[%arg](s)
        { [ map { @$_ } @{$item[1]} ] }

tvalue:
    iso8601
    | epoch

# backtracking optimization
_vvalue:
    <matchrule:$arg[0]> vector_sep(?)
        { [ $item[1] ] }

vector_sep:
    /,|\s+/

int:
    # $RE{num}{int} from Regexp::Common::number
    /(?:(?:[+-]?)(?:[0-9]+))/

    # based on $RE{num}{real} from Regexp::Common::number
float:
    /(?:(?i)(?:[+-]?)(?:(?=[0-9]|[.])(?:[0-9]*)(?:(?:[.])(?:[0-9]{0,}))?)(?:(?:[Ee])(?:(?:[+-]?)(?:[0-9]+))|))/
    | inf
    | nan

inf:
    /[+-]?inf(?:inity)?/i
        {
            if ($item[1] =~ /^-/) {
                $return = "-inf";
            } else {
                $return = "+inf";
            }
        }
nan:
    /[+-]?nan(?:\(\S*?\))?/i
        { $return = "nan" }

bool:
    /[tf]/i
        { $item[1] =~ /t/i ? 1 : 0 }

string:
    /(?:\S[^#\n]*)?[^#\n ]/
        # trim tailing the trailing white that's left when the string is
        # followed by a comment (#)
        { 
            $item[1] =~ s/\s*$//;
            $return = $item[1];
        }
    | NULL

word:
    /(?:[^#\s\n]+)/

to_end_of_line:
    /[^\n]*/
        {
            my $comment = $item[1];
            # remove leading whitespace
            $comment =~ s/^\s+//;
            # remove trailing whitespace
            $comment =~ s/\s+$//;

            $return = $comment;
        }

UTC:
    iso8601
    | utc_epoch
    | NULL

UT1:
    iso8601
    | epoch
    | NULL

TAI:
    iso8601
    | epoch
    | NULL

TT:
    iso8601
    | epoch
    | NULL

iso8601:
    # based on code from DateTime::Format::ISO8601
    / \d{4} -?? \d\d -?? \d\d T?? \d\d :?? \d\d :?? \d\d (?:[\.,] (\d+))? Z?/x
        { DateTime::Format::ISO8601->parse_datetime( $item[1] ) }

utc_epoch:
    / (-?\d{1,19}) \s*,\s* (\d{1,9}) (?:\s*,\s* (\d))? /x
        {{
            sec         => $1,
            nsec        => $2,
            leapsecond  => $3,
        }}

epoch:
    / (-?\d{1,19}) \s*,\s* (\d{1,9}) /x
        {{
            sec     => $1,
            nsec    => $2,
        }}
NULL:
    /NULL/
    { $return = "NULL" }

eofile:
    /^\z/
