File Coverage

blib/lib/Soar/Production/Parser/PRDGrammar.pm

Criterion	Covered	Total	%
statement	6	6	100.0
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	8	8	100.0

#
# This file is part of Soar-Production
#
# This software is copyright (c) 2012 by Nathan Glenn.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
package Soar::Production::Parser::PRDGrammar;
# ABSTRACT: Parse::RecDescent grammar for Soar productions

use strict;
use warnings;

our $VERSION = '0.03'; # VERSION

#this grammar will return a parse tree of a production
our $GRAMMAR = <<'EOGRAMMAR';

	parse:

          (?: \s+						# Whitespace
          |   (?:;\s*)?\# [^\n]* \n?	# End of line comment
          )
		)*}> production /\Z/
		{
			$item[2]
		}
	#future work: can be sp or tp (normal or template production)
	production: /sp/ "{" beginning LHS "-->" RHS "}"
		{
			my %return;
			@return{ keys %{$item[3]}} = values %{$item[3]};
			$return{LHS} = $item{LHS};
			$return{RHS} = $item{RHS}->{rhsActions};
			\%return;
		}
	beginning: prodname documentation(?) flag(s?)
		{
			{name => $item[1], doc => $item[2] ? $item[2][0] : undef, flags => $item[3]}
		}
	prodname: /[\dA-Za-z][\dA-Za-z\$%&*=>

	#documentation can span many lines
	documentation: '"'  /[^"]*/ms '"'
		{
			$item[3]
		}
	flag: ':'  /o-support|i-support|chunk|default|interrupt|template/
	LHS: cond(s)
		{
			{ conditions		=> $item[1] }
		}
	condType: "state" | "impasse"
	cond:
		positiveCond
		{
			{ negative => 'no', condition => $item{positiveCond} }
		}
		| negativeCond
		{
			{ negative => 'yes', condition => $item{negativeCond} }
		}
	negativeCond: "-" positiveCond
	positiveCond: condsForOneId
		{
			$item{condsForOneId};
		}
		| "{"  cond(s) "}"
		{
			{ 'conjunction' => $item[3] }
		}
	condsForOneId: "("  condType(?) idTest(?) attrValueTests(s?) ")"
		#only a state_imp_cond can be missing an idTest or attrValueTests

			not defined $item[3] and (
				not defined $item[4] or $#{$item[5]} == -1
			)
		} >
		{
			{
				condType 	=> ($#{$item[3]} != -1 ? $item[3][0] : undef),
				idTest 		=> ($#{$item[4]} != -1 ? $item[4][0]->{test} : undef),
				attrValueTests =>	$item[5],
			}
		}
	idTest: test
		{
			{ test => $item{test} }
		}
	attrValueTests: /-?/ attTest valueTest(s?)
		{
			{
				negative 	=> ($item[1] ? 'yes' : 'no'),
				attrs 		=> $item[2],
				values		=> $item[3],
			}
		}
	attTest: "^"  test(s /\./)
	valueTest: test /\+?/
		{
			{
				test 	=> $item{test},
				'+'		=> ($item[2] ? 'yes' : 'no'),
			}
		}
		| condsForOneId /\+?/
		{
			{
				conds	=> $item{condsForOneId},
				'+'		=> ($item[2] ? 'yes' : 'no'),
			}
		}
	test:
		conjunctiveTest
		{
			{ conjunctiveTest => $item{conjunctiveTest} }
		}
		| simpleTest
		{
			{ simpleTest => $item{simpleTest} }
		}
	conjunctiveTest: "\{"  simpleTest(s) "\}"
		{
			$item[3]
		}
	simpleTest:
		disjunctionTest
		{
			{ disjunctionTest => $item{disjunctionTest} }
		}
		| relationalTest
		{
			{ relationTest => $item{relationalTest} }
		}
		| singleTest
		{
			$item{singleTest}
		}
	disjunctionTest: /<<(?=\s)/  constant(s) />>/ #don't have to worry about look for whitespace on second one; if no space is there, the parser will think it's a string and fail.
	{
		$item[3]
	}
	relationalTest: relation singleTest #note that I removed a (?) from relation, and added singleTest to simpleTest
		{
			{ relation => ($item{relation} || undef), test => $item{singleTest} }
		}
	# /<(?=\s)/ ensures we don't match the beginning of a variable
	relation:  "<=>" | "<>" | "<=" | ">=" | ">" | /<(?=\s)/ | "="

	singleTest:
		variable
		{
			$item{variable}
		}
		| constant
		{
			$item{constant}
		}

	#change skip so we can't have
	variable: /<[A-Za-z0-9\$%&*+\/:=?_<>-]+(?)>/
		{
			$item[1] =~ s/^<(.*)>$/$1/;
			{variable => $item[1] }
		}

	RHS: rhsAction(s?)
		{
			{ rhsActions => $item[1] }
		}

	rhsAction:
		funcCall
		{
			{ funcCall => $item{funcCall} }
		}
		| "(" variable attrValueMake(s) ")"
		{
			{ variable => $item{variable}->{variable}, attrValueMake => $item[3] }
		}

	funcCall: "(" funcName  rhsValue(s?) ")"
		{
			{ function => $item{funcName}, args => $item[4] }
		}
	funcName: "+" | "-" | "*" | "/" | symConstant
	rhsValue: variable | constant | "(crlf)" | funcCall
	attrValueMake:  valueMake(s)
		{
			{ attr => $item[1], valueMake => $item[2] }
		}
	attr: "^"  variableOrSymConstant
	variableOrSymConstant: variable | symConstant
	valueMake: rhsValue preferenceSpecifier(s?)
		{
			#add an acceptable preference if no preference is specified
			my $preferences = $item[2];
			if($#$preferences == -1){
				$preferences = [{
                                  'value' => '+',
                                  'type' => 'unary'
                                }];
			}
			{ rhsValue => $item{rhsValue},  preferences => $preferences }
		}

	preferenceSpecifier:
		unaryOrBinaryPreference rhsValue comma(?)
		{
			{ type => 'binary', value => $item{unaryOrBinaryPreference}, compareTo => $item{rhsValue} }
		}
		| unaryPreference comma(?)
		{
			{ type => 'unary', value => $item{unaryPreference} };
		}

	comma: ","

	unaryPreference: "+" | "-" | "!" | "~" | "@" | unaryOrBinaryPreference

	#negative lookahead necessary to prevent matching  as two specifiers and a constant
	unaryOrBinaryPreference: ">" | ...!variable  "<" | "=" | "&"

	#put float and int first, since symConstant can technically match the same values.
	constant:
		floatConstant
		{
			{ constant => $item{floatConstant}, type => 'float' }
		}
		| intConstant
		{
			{ constant => $item{intConstant}, type => 'int' }
		}
		| symConstant
		{
			{ constant => $item{symConstant}, type => 'sym' }
		}
	symConstant: string { $item{string} } | quoted { $item{quoted} }
	string: /[A-Za-z0-9\$%&*+\/:=?_><-]+/
		$/} > #reject if we've actually found a variable

			$item[1] =~ /^ [+!~><=-]+ $/x and
			$item[1] !~ /^ (?: >< | [<>]{3,}) $/x

			}
		> #reject if the name contains only preference characters

			# "" look like typos. Could have missed a pointy brace.
			if( $item[1] =~ /^<.*|.*>$/ ){
				use Carp;
				carp "Suspicious string constant: \"$item[1]\". Did you mean to use a variable or disjunction?";
			}
		}>
		{
			# "" look like typos. Could have missed a pointy brace. Convert to quoted like Soar does.
			if( $item[1] =~ /^<.*|.*>$/ ){
				$return = { type => 'quoted', value => $item[1] };
			}else{
				$return = { type => 'string', value => $item[1] };
			}
		}
	#TODO: note that in Soar, || is ignored and treated like .
	quoted: /\|(?:\\[|]|[^|])*\|/
		{
			#remove leading and trailing vertical bar
			$item[1] =~ s{^\|}{};
			$item[1] =~ s{\|$}{};

			#unescape other vertical bars
			$item[1] =~ s{\\\|}{|}g;

			{ type => 'quoted', value => $item[1] }
		}
	intConstant: /-?[0-9]+/
	floatConstant:
		scientific { $item{scientific} }
		| normal { $item{normal} }

	#strangely enough, the section after the period is optional; '1.' is legal.
	normal: /^[-+]?[0-9]*\.[0-9]*/
	scientific: /[+-]?[0-9]\.[0-9]+[eE][-+]?[0-9]+/
EOGRAMMAR

1;

__END__