# pX/Common/p6rule.t - fglock
use strict;
use warnings;
#require 'iterator_engine.pl';
use Test::More qw(no_plan);
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Pad = '# ';
use_ok( 'Pugs::Runtime::Rule' );
use Pugs::Runtime::Match::Ratchet;
=for doc see Runtime::Rule
A "rule" function gets as argument a list:
0 - a string to match
1 - an optional "continuation"
2 - a partially built match tree
3 - a leaf pointer in the match tree
4 - a grammar name
5 - pos - TODO - change #0 ???
#6 - the whole string to match - TODO - unify with $_[0]
7 - argument list - <subrule($x,$y)>
=cut
my ( $rule, $match );
{
$rule =
Pugs::Runtime::Rule::constant( 'a' );
$rule->( 'a123', undef, $match, $match, undef, 0, undef, undef );
#print Dumper( $match );
ok ( $match, "/a/ #1" );
is ( $match->to, 1, "tail is ok" );
is ( "$match", "a", "stringification" );
$rule->( 'c123', undef, $match, $match, undef, 0, undef, undef );
ok ( ! $match, "/c/ #2" );
#print Dumper( $match );
}
{
$rule =
Pugs::Runtime::Rule::alternation( [
Pugs::Runtime::Rule::constant( 'a' ),
Pugs::Runtime::Rule::constant( 'c' ),
] );
$rule->( 'a123', undef, $match, $match, undef, 0, undef, undef );
ok ( $match, "/a|c/ #1" );
is ( $match->to, 1, "tail is ok" );
$rule->( 'c123', undef, $match, $match, undef, 0, undef, undef );
ok ( $match, "/a|c/ #2" );
is ( $match->to, 1, "tail is ok" );
#print Dumper( $match );
}
{
$rule =
Pugs::Runtime::Rule::concat( [
Pugs::Runtime::Rule::constant( 'a' ),
Pugs::Runtime::Rule::constant( 'c' ),
] );
$rule->( 'ac123', undef, $match, $match, undef, 0, undef, undef );
ok ( $match, "/ac/ #1" );
is ( $match->to, 2, "tail is ok" );
$rule->( 'cc123', undef, $match, $match, undef, 0, undef, undef );
ok ( ! $match, "/ac/ #2" );
#print Dumper( $match );
}
{
$rule =
Pugs::Runtime::Rule::named(
'const',
Pugs::Runtime::Rule::constant( 'a' )
);
$rule->( 'a123', undef, $match, $match, undef, 0, undef, undef );
#print Dumper( $match );
ok ( $match, "/a/ #1" );
is ( $match->{const}, 'a', "named var" );
# print Dumper( $match );
}
{
$rule =
Pugs::Runtime::Rule::concat( [
Pugs::Runtime::Rule::constant( 'a' ),
Pugs::Runtime::Rule::before(
Pugs::Runtime::Rule::constant( 'c' )
),
] );
$rule->( 'ac123', undef, $match, $match, undef, 0, undef, undef );
ok ( $match, "/a<before c>/ #1" );
# print Dumper( $match );
}
{
$rule =
Pugs::Runtime::Rule::non_greedy_plus(
Pugs::Runtime::Rule::alternation( [
Pugs::Runtime::Rule::constant( 'a' ),
Pugs::Runtime::Rule::constant( 'c' ),
] ),
);
$rule->( 'a123', undef, $match, $match, undef, 0, undef, undef );
#print Dumper( $match );
ok ( $match, "/[a|c]/ #1" );
is ( $match->to, 1, "tail is ok" );
$rule->( 'c123', undef, $match, $match, undef, 0, undef, undef );
ok ( $match, "/[a|c]/ #2" );
is ( $match->to, 1, "tail is ok" );
# print Dumper( $match );
}
{
# alternation backtracking
$rule =
Pugs::Runtime::Rule::concat( [
Pugs::Runtime::Rule::optional(
Pugs::Runtime::Rule::constant( 'a' ),
),
Pugs::Runtime::Rule::constant( 'd' ),
] );
$rule->( 'ad123', undef, $match, $match, undef, 0, undef, undef );
#print Dumper( $match );
ok ( $match, "/a?d/ #1" );
is ( $match->to, 2, "tail is ok" );
$rule->( 'd123', undef, $match, $match, undef, 0, undef, undef );
ok ( $match, "/a?d/ #2" );
is ( $match->to, 1, "tail is ok" );
# print Dumper( $match );
}
{
# concat backtracking
$rule =
Pugs::Runtime::Rule::concat( [
Pugs::Runtime::Rule::non_greedy_plus(
Pugs::Runtime::Rule::alternation( [
Pugs::Runtime::Rule::constant( 'a' ),
Pugs::Runtime::Rule::constant( 'c' ),
] ) ),
Pugs::Runtime::Rule::constant( 'd' ),
] );
$rule->( 'ad123', undef, $match, $match, undef, 0, undef, undef );
#print Dumper( $match );
ok ( $match, "/[a|c]+?d/ #1" );
is ( $match->to, 2, "tail is ok" );
$rule->( 'acacd123', undef, $match, $match, undef, 0, undef, undef );
ok ( $match, "/[a|c]+?d/ #2" );
is ( $match->to, 5, "tail is ok" );
# print Dumper( $match );
}
{
$rule =
Pugs::Runtime::Rule::greedy_star(
Pugs::Runtime::Rule::constant( 'a' )
);
is ( ref $rule, "CODE", "rule 'a*' is a coderef" );
$rule->( 'aa', undef, $match, $match, undef, 0, undef, undef );
# print Dumper( $match );
ok ( $match, "/a*/" );
# print Dumper( $match );
$rule->( '', undef, $match, $match, undef, 0, undef, undef );
ok ( $match, "matches 0 occurrences" );
# print Dumper( $match );
}
{
$rule =
Pugs::Runtime::Rule::greedy_plus(
Pugs::Runtime::Rule::constant( 'a' )
);
$rule->( 'aa', undef, $match, $match, undef, 0, undef, undef );
ok ( $match, "/a+/" );
$rule->( '!!', undef, $match, $match, undef, 0, undef, undef );
ok ( ! $match, "rejects unmatching text" );
}
{
$rule =
Pugs::Runtime::Rule::concat( [
Pugs::Runtime::Rule::greedy_plus(
Pugs::Runtime::Rule::alternation( [
Pugs::Runtime::Rule::constant( 'a' ),
Pugs::Runtime::Rule::constant( 'c' ),
] ),
),
Pugs::Runtime::Rule::constant( 'ab' )
] );
$rule->( 'aacaab', undef, $match, $match, undef, 0, undef, undef );
ok ( $match, "/[a|c]+ab/ with backtracking" );
# print "test: ",Dumper( $match );
}
{
$rule =
Pugs::Runtime::Rule::concat( [
Pugs::Runtime::Rule::named(
'const1',
Pugs::Runtime::Rule::constant( 'a' )
),
Pugs::Runtime::Rule::named(
'const2',
Pugs::Runtime::Rule::constant( 'b' )
),
Pugs::Runtime::Rule::named(
'const3',
Pugs::Runtime::Rule::constant( 'c' )
),
] );
$rule->( 'abc123', undef, $match, $match, undef, 0, undef, undef );
print Dumper( $match );
ok ( $match, "/(a)(b)(c)/ named #1" );
is ( $match->{const}, 'a', "named var" );
# print Dumper( $match );
}
{
$rule =
Pugs::Runtime::Rule::concat( [
Pugs::Runtime::Rule::positional(
Pugs::Runtime::Rule::constant( 'a' )
),
Pugs::Runtime::Rule::positional(
Pugs::Runtime::Rule::constant( 'b' )
),
Pugs::Runtime::Rule::positional(
Pugs::Runtime::Rule::constant( 'c' )
),
] );
$rule->( 'abc123', undef, $match, $match, undef, 0, undef, undef );
print Dumper( $match );
ok ( $match, "/(a)(b)(c)/ positional #1" );
is ( $match->{const}, 'a', "named var" );
# print Dumper( $match );
}
__END__
{
$rule =
Pugs::Runtime::Rule::non_greedy_plus(
Pugs::Runtime::Rule::alternation( [
Pugs::Runtime::Rule::constant( 'a' ),
Pugs::Runtime::Rule::constant( 'c' ),
] ),
);
$rule->( '', undef, $match, $match, undef, 0, undef, undef );
( $stat, $assertion, $match, $tail ) = $rule->( 'aacaab', undef, {capture=>1} );
ok ( defined $match, "/[a|c]+/" );
is ( $tail, 'acaab', "tail is ok" );
#print Dumper( $match );
}
{
$rule =
Pugs::Runtime::Rule::concat( [
Pugs::Runtime::Rule::non_greedy_plus(
Pugs::Runtime::Rule::alternation( [
Pugs::Runtime::Rule::constant( 'a' ),
Pugs::Runtime::Rule::constant( 'c' ),
] ),
),
Pugs::Runtime::Rule::constant( 'cb' )
] );
( $stat, $assertion, $match, $tail ) = $rule->( 'aacacb' );
ok ( defined $match, "/[a|c]+?ab/ with backtracking" );
#print Dumper( $match );
}
{
# tests for a problem found in the '|' implementation in p6rule parser
my $rule =
Pugs::Runtime::Rule::constant( 'a' );
my $alt =
Pugs::Runtime::Rule::concat( [
$rule,
Pugs::Runtime::Rule::optional (
Pugs::Runtime::Rule::concat( [
Pugs::Runtime::Rule::constant( '|' ),
$rule
] )
)
] );
( $stat, $assertion, $match, $tail ) = $alt->( 'a' );
ok ( defined $match, "/a|a/ #1" );
( $stat, $assertion, $match, $tail ) = $alt->( 'a|a' );
ok ( defined $match, "/a|a/ #2" );
# adding '*' caused a deep recursion error (fixed)
$alt =
Pugs::Runtime::Rule::concat(
$rule,
Pugs::Runtime::Rule::greedy_star(
Pugs::Runtime::Rule::concat(
Pugs::Runtime::Rule::constant( '|' ),
$rule
)
)
);
( $stat, $assertion, $match, $tail ) = $alt->( 'a' );
ok ( defined $match, "/a [ |a ]*/ #1" );
( $stat, $assertion, $match, $tail ) = $alt->( 'a|a' );
ok ( defined $match, "/a [ |a ]*/ #2" );
( $stat, $assertion, $match, $tail ) = $alt->( 'a|a|a' );
ok ( defined $match, "/a [ |a ]*/ #3" );
}
__END__
# old tests
print "word\n", Dumper(
&{'rule::<word>'}( 0, qw(b a a ! !) )
);
print "word concat\n", Dumper(
rule::concat( \&{'rule::<word>'}, \&{'rule::<ws>'} )->( 0, qw(b a ),' ' )
);
print "non_greedy + backtracking\n", Dumper(
rule::concat(
rule::non_greedy( rule::constant('a') ),
rule::constant('ab')
)->( 0, qw(a a a a b) )
);
print "alternation + backtracking\n", Dumper(
rule::concat(
rule::alternation( rule::constant('a'), rule::constant('ab') ),
rule::constant('ab')
)->( 0, qw(a b a b) )
);
print "alternation + greedy + backtracking -- (ab,a,ab)(ab)\n", Dumper(
rule::concat(
rule::greedy(
rule::alternation( rule::constant('a'), rule::constant('ab') )
),
rule::constant('ab')
)->( 0, qw(a b a a b a b) )
);