Skip to content

Commit

Permalink
Refactor compiler
Browse files Browse the repository at this point in the history
  • Loading branch information
@ingydotnet
ingydotnet committed Mar 12, 2013
1 parent 11fd893 commit 38dbccc
Show file tree
Hide file tree
Showing 8 changed files with 132 additions and 121 deletions.
2 changes: 1 addition & 1 deletion lib/TestML.pm
View file
Expand Up @@ -19,7 +19,7 @@ our $VERSION = '0.30';

# Accessors for TestML objects:
has runtime => 'TestML::Runtime::TAP';
has compiler => 'TestML::Compiler';
has compiler => 'TestML::Compiler::Pegex';
has bridge => 'main';
has library => [
'TestML::Library::Standard',
Expand Down
145 changes: 47 additions & 98 deletions lib/TestML/Compiler.pm
View file
@@ -1,55 +1,37 @@
package TestML::Compiler;

use TestML::Base;
use TestML::Grammar;
use TestML::AST;
use Pegex::Parser;

# XXX This code is too complicated. It preprocesses the TestML code, splits it
# into 2 sections and calls a separate Pegex parse on each. This could all be
# handled in Pegex, but probably not worth it just yet.
use TestML::Runtime;

has code => ();
has data => ();
has text => ();
has directives => ();
has function => ();

# Take a TestML document and compile it into a TestML::Function object.
sub compile {
my ($self, $input) = @_;

my $result = $self->preprocess($input, 'top');

my ($code, $data) = @$result{qw(code data)};

my $parser = Pegex::Parser->new(
grammar => TestML::Grammar->new,
receiver => TestML::AST->new,
);

$parser->parse($code, 'code_section')
or die "Parse TestML code section failed";

$parser = $self->fixup_grammar($parser, $result);
$self->preprocess($input, 'top');
$self->compile_code;
$self->compile_data;

if (length $data) {
$parser->parse($data, 'data_section')
or die "Parse TestML data section failed";
if ($self->directives->{DumpAST}) {
XXX($self->function);
}

if ($result->{DumpAST}) {
XXX($parser->receiver->function);
}

my $function = $parser->receiver->function;
$function->outer(TestML::Function->new());

return $function;
$self->function->outer(TestML::Function->new());
return $self->function;
}

sub preprocess {
my ($self, $text, $top) = @_;
my ($self, $input, $top) = @_;

my @parts = split /^((?:\%\w+.*|\#.*|\ *)\n)/m, $text;
my @parts = split /^((?:\%\w+.*|\#.*|\ *)\n)/m, $input;

$text = '';
$input = '';

my $result = {
my $directives = $self->{directives} = {
TestML => '',
DataMarker => '',
BlockMarker => '===',
Expand All @@ -60,109 +42,76 @@ sub preprocess {
for my $part (@parts) {
next unless length($part);
if ($part =~ /^(\#.*|\ *)\n/) {
$text .= "\n";
$input .= "\n";
next;
}
if ($part =~ /^%(\w+)\s*(.*?)\s*\n/) {
my ($directive, $value) = ($1, $2);
$text .= "\n";
$input .= "\n";
if ($directive eq 'TestML') {
die "Invalid TestML directive"
unless $value =~ /^\d+\.\d+\.\d+$/;
die "More than one TestML directive found"
if $result->{TestML};
$result->{TestML} = TestML::Str->new(value => $value);
if $directives->{TestML};
$directives->{TestML} = TestML::Str->new(value => $value);
next;
}
$order_error = 1 unless $result->{TestML};
$order_error = 1 unless $directives->{TestML};
if ($directive eq 'Include') {
my $runtime = $TestML::Runtime::singleton
or die "Can't process Include. No runtime available";
my $sub_result =
$self->preprocess($runtime->read_testml_file($value));
$text .= $sub_result->{text};
$result->{DataMarker} = $sub_result->{DataMarker};
$result->{BlockMarker} = $sub_result->{BlockMarker};
$result->{PointMarker} = $sub_result->{PointMarker};
my $include = ref($self)->new;
$include->preprocess($runtime->read_testml_file($value));
$input .= $include->text;
$directives->{DataMarker} =
$include->directives->{DataMarker};
$directives->{BlockMarker} =
$include->directives->{BlockMarker};
$directives->{PointMarker} =
$include->directives->{PointMarker};
die "Can't define %TestML in an Included file"
if $sub_result->{TestML};
if $include->directives->{TestML};
}
elsif ($directive =~ /^(DataMarker|BlockMarker|PointMarker)$/) {
$result->{$directive} = $value;
$directives->{$directive} = $value;
}
elsif ($directive =~ /^(DebugPegex|DumpAST)$/) {
$value = 1 unless length($value);
$result->{$directive} = $value;
$directives->{$directive} = $value;
}
else {
die "Unknown TestML directive '$directive'";
}
}
else {
$order_error = 1 if $text and not $result->{TestML};
$text .= $part;
$order_error = 1 if $input and not $directives->{TestML};
$input .= $part;
}
}

if ($top) {
die "No TestML directive found"
unless $result->{TestML};
unless $directives->{TestML};
die "%TestML directive must be the first (non-comment) statement"
if $order_error;

my $DataMarker = $result->{DataMarker} ||= $result->{BlockMarker};
my $DataMarker = $directives->{DataMarker} ||= $directives->{BlockMarker};
my ($code, $data);
if ((my $split = index($text, "\n$DataMarker")) >= 0) {
$result->{code} = substr($text, 0, $split + 1);
$result->{data} = substr($text, $split + 1);
if ((my $split = index($input, "\n$DataMarker")) >= 0) {
$self->{code} = substr($input, 0, $split + 1);
$self->{data} = substr($input, $split + 1);
}
else {
$result->{code} = $text;
$result->{data} = '';
$self->{code} = $input;
$self->{data} = '';
}

$result->{code} =~ s/^\\(\\*[\%\#])/$1/gm;
$result->{data} =~ s/^\\(\\*[\%\#])/$1/gm;
$self->{code} =~ s/^\\(\\*[\%\#])/$1/gm;
$self->{data} =~ s/^\\(\\*[\%\#])/$1/gm;
}
else {
$result->{text} = $text;
}

return $result;
}

# TODO This can be moved to the AST some day.
sub fixup_grammar {
my ($self, $parser, $hash) = @_;

my $namespace = $parser->receiver->function->namespace;
$namespace->{TestML} = $hash->{TestML};

my $tree = $parser->grammar->tree;

my $point_lines = $tree->{point_lines}{'.rgx'};

my $block_marker = $hash->{BlockMarker};
if ($block_marker) {
$block_marker =~ s/([\$\%\^\*\+\?\|])/\\$1/g;
$tree->{block_marker}{'.rgx'} = qr/\G$block_marker/;
$point_lines =~ s/===/$block_marker/;
$self->{text} = $input;
}

my $point_marker = $hash->{PointMarker};
if ($point_marker) {
$point_marker =~ s/([\$\%\^\*\+\?\|])/\\$1/g;
$tree->{point_marker}{'.rgx'} = qr/\G$point_marker/;
$point_lines =~ s/\\-\\-\\-/$point_marker/;
}

$tree->{point_lines}{'.rgx'} = qr/$point_lines/;

Pegex::Parser->new(
grammar => $parser->grammar,
receiver => $parser->receiver,
);

}

1;
65 changes: 65 additions & 0 deletions lib/TestML/Compiler/Pegex.pm
View file
@@ -0,0 +1,65 @@
package TestML::Compiler::Pegex;
use TestML::Base;
extends 'TestML::Compiler';

use TestML::Compiler::Pegex::Grammar;
use TestML::Compiler::Pegex::AST;
use Pegex::Parser;

has parser => ();

sub compile_code {
my ($self) = @_;

$self->{parser} = Pegex::Parser->new(
grammar => TestML::Compiler::Pegex::Grammar->new,
receiver => TestML::Compiler::Pegex::AST->new,
);
$self->fixup_grammar;

$self->parser->parse($self->code, 'code_section')
or die "Parse TestML code section failed";
}

sub compile_data {
my ($self) = @_;

if (length $self->data) {
$self->parser->parse($self->data, 'data_section')
or die "Parse TestML data section failed";
}

$self->{function} = $self->parser->receiver->function;
}

# TODO This can be moved to the AST some day.
sub fixup_grammar {
my ($self) = @_;

my $parser = $self->parser;

my $namespace = $parser->receiver->function->namespace;
$namespace->{TestML} = $self->directives->{TestML};

my $tree = $parser->grammar->tree;

my $point_lines = $tree->{point_lines}{'.rgx'};

my $block_marker = $self->directives->{BlockMarker};
if ($block_marker) {
$block_marker =~ s/([\$\%\^\*\+\?\|])/\\$1/g;
$tree->{block_marker}{'.rgx'} = qr/\G$block_marker/;
$point_lines =~ s/===/$block_marker/;
}

my $point_marker = $self->directives->{PointMarker};
if ($point_marker) {
$point_marker =~ s/([\$\%\^\*\+\?\|])/\\$1/g;
$tree->{point_marker}{'.rgx'} = qr/\G$point_marker/;
$point_lines =~ s/\\-\\-\\-/$point_marker/;
}

$tree->{point_lines}{'.rgx'} = qr/$point_lines/;
}

1;
2 changes: 1 addition & 1 deletion lib/TestML/AST.pm → lib/TestML/Compiler/Pegex/AST.pm
View file
@@ -1,4 +1,4 @@
package TestML::AST;
package TestML::Compiler::Pegex::AST;
use TestML::Base;
extends 'Pegex::Tree';

Expand Down
4 changes: 1 addition & 3 deletions lib/TestML/Grammar.pm → lib/TestML/Compiler/Pegex/Grammar.pm
View file
@@ -1,9 +1,7 @@
package TestML::Grammar;
package TestML::Compiler::Pegex::Grammar;
use TestML::Base;
extends 'Pegex::Grammar';

# TODO Move grammar and AST into Compiler library once Pegex can do a smarter
# in place compile.
use constant file => '../testml-pgx/testml.pgx';

sub make_tree {
Expand Down
4 changes: 2 additions & 2 deletions t/compile-lite.t
View file
Expand Up @@ -11,7 +11,7 @@ BEGIN {
}

use TestML;
use TestML::Compiler;
use TestML::Compiler::Pegex;
use TestML::Compiler::Lite;
use YAML::XS;

Expand All @@ -33,7 +33,7 @@ Title = "O HAI TEST";
--- output: I LOVE LUCY
';

my $func = TestML::Compiler->new->compile($testml);
my $func = TestML::Compiler::Pegex->new->compile($testml);
my $func_lite = TestML::Compiler::Lite->new->compile($testml);

is Dump($func_lite), Dump($func),
Expand Down
4 changes: 2 additions & 2 deletions t/compile-testml-document.t
View file
@@ -1,6 +1,6 @@
use Test::More tests => 21;

use TestML::Compiler;
use TestML::Compiler::Pegex;

my $testml = '
# A comment
Expand All @@ -20,7 +20,7 @@ Title = "O HAI TEST";
--- output: I LOVE LUCY
';

my $func = TestML::Compiler->new->compile($testml);
my $func = TestML::Compiler::Pegex->new->compile($testml);
ok $func, 'TestML string matches against TestML grammar';
is $func->namespace->{TestML}->value, '0.1.0', 'Version parses';
is $func->statements->[0]->expression->calls->[0]->args->[1]->calls->[0]->value, '2', 'Plan parses';
Expand Down
27 changes: 13 additions & 14 deletions t/compile.t
View file
Expand Up @@ -11,22 +11,22 @@ BEGIN {
}

use TestML::Runtime;
use TestML::Compiler;
use TestML::Compiler::Pegex;
use TestML::Compiler::Lite;
use YAML::XS;

test('t/testml/arguments.tml');
test('t/testml/assertions.tml');
test('t/testml/basic.tml');
test('t/testml/dataless.tml');
test('t/testml/exceptions.tml');
test('t/testml/external.tml');
test('t/testml/function.tml');
test('t/testml/label.tml');
test('t/testml/markers.tml');
test('t/testml/semicolons.tml');
test('t/testml/truth.tml');
test('t/testml/types.tml');
test('t/testml/arguments.tml', 'TestML::Compiler::Pegex');
test('t/testml/assertions.tml', 'TestML::Compiler::Pegex');
test('t/testml/basic.tml', 'TestML::Compiler::Pegex');
test('t/testml/dataless.tml', 'TestML::Compiler::Pegex');
test('t/testml/exceptions.tml', 'TestML::Compiler::Pegex');
test('t/testml/external.tml', 'TestML::Compiler::Pegex');
test('t/testml/function.tml', 'TestML::Compiler::Pegex');
test('t/testml/label.tml', 'TestML::Compiler::Pegex');
test('t/testml/markers.tml', 'TestML::Compiler::Pegex');
test('t/testml/semicolons.tml', 'TestML::Compiler::Pegex');
test('t/testml/truth.tml', 'TestML::Compiler::Pegex');
test('t/testml/types.tml', 'TestML::Compiler::Pegex');

test('t/testml/arguments.tml', 'TestML::Compiler::Lite');
test('t/testml/basic.tml', 'TestML::Compiler::Lite');
Expand All @@ -35,7 +35,6 @@ test('t/testml/semicolons.tml', 'TestML::Compiler::Lite');

sub test {
my ($file, $compiler) = @_;
$compiler ||= 'TestML::Compiler';
(my $filename = $file) =~ s!(.*)/!!;
my $runtime = TestML::Runtime->new(base => $1);
my $testml = $runtime->read_testml_file($filename);
Expand Down

0 comments on commit 38dbccc

Please sign in to comment.