Marpa::R2これは、オーバーロードされたオブジェクトを使用するソリューションです。予想よりも長くなりましたが、往復互換に見えます。
ヘッダーは単純です。
use strict; use warnings; use feature 'say';
use Marpa::R2;
use constant DEBUG => 0;
exit main();
これには、Perl5バージョン10以降が必要です。次はparseサブルーチンです。これにより、トークン化が行われ、パーサーが呼び出されます。ほとんどのトークンは（明示的なコードではなく）データとして指定されているため、簡単に拡張できます。
は$print_diag匿名のサブです。とを閉じて、$stringに$last_pos似た適切なエラーメッセージを出力できますdie。トークン化の問題のコンテキストをHERE-->矢印で示します。
$match同様の閉鎖の場合。使用可能なすべてのトークンをループして、一致するトークンを返すか、失敗するとfalse値を返します。正規表現を使用しm/\G.../gcます。これらはに似てs/^...//いますが、文字列を破棄しないでください。\Gアサーションはで一致しますpos($string)。この/cオプションは、失敗が変わらないことを確認しますpos。
文字列トークンは手動で照合されます。エスケープを処理することをお勧めします。いくつかの一般的なエスケープ（ \\、、、、および行継続バックスラッシュ）のサポートを追加しました。\"\n\t
ループはトークンをプルし、TOKENそれらをレコグナイザーに詰め込みます。これには、コードがほとんどなく、エラー処理が多く含まれています。
最後に、最初の可能な$parseツリー（複数ある可能性があります）を取得し、成功したかどうかを確認します。その場合、データ構造を返します。
my $grammar; # filled later in INIT block
sub parse {
my ($string) = @_;
my ($last_pos, $length) = (0, length $string);
my $rec = Marpa::R2::Recognizer->new({ grammar => $grammar });
my $print_diag = sub {
my ($problem) = @_;
my ($behind, $ahead) = (15, 30);
my $start = $last_pos > $behind ? $last_pos - $behind : 0;
say STDERR "$problem at ", map ">>$_<<", join " HERE-->",
substr($string, $start, $behind),
substr($string, $last_pos, $ahead );
exit 1;
};
my @capture_token = (
[qr/true|false/ => 'Bool'], # bool must come before ident
[qr/-?\d+(?:\.\d+)?/=> 'Number'], # number must come before ident
[qr/\w+/ => 'Ident'],
);
my @non_capture_token = (
[qr/\{/ => 'LCurly'],
[qr/\}/ => 'RCurly'],
[qr/=/ => 'Equal'],
[qr/,/ => 'Comma'],
);
my $match = sub {
# try String manually here:
if ($string =~ m/\G"( (?: [^"]++ | \\. )*+ )"/gcxs) {
my $str = $1;
my %escapes = ( n => "\n", t => "\t", "\n" => '' );
$str =~ s{\\(.)}{ $escapes{$1} // $1 }esg;
return String => $str;
}
for (@non_capture_token) {
my ($re, $type) = @$_;
return $type if $string =~ m/\G$re/gc;
}
for (@capture_token) {
my ($re, $type) = @$_;
return $type, $1 if $string =~ m/\G($re)/gc;
}
return;
};
pos $string = $last_pos; # set match start for \G assertion to beginning
TOKEN: while ($last_pos < $length) {
next TOKEN if $string =~ m/\G\s+/gc;
next TOKEN if $string =~ m/\G\#\N+/gc; # skip comments if you have such
if (my @token = $match->()) {
say STDERR "Token [@token]" if DEBUG;
my $ok = $rec->read(@token);
unless (defined $ok) {
$print_diag->("Token [@token] rejected");
}
} else {
$print_diag->("Can't understand input");
}
} continue {
$last_pos = pos $string;
}
my $parse = $rec->value;
unless ($parse) {
say STDERR "Could not parse input";
say STDERR "The Progress so far:";
say STDERR $rec->show_progress;
exit 1;
}
return $$parse;
}
次に、文法を指定します。Marpaは、ここで使用するBNFのような表記法で処理できます。私は主に低レベルのメソッドより上の構文糖衣です。アクション（後で記述します）を指定でき、トークンをパレンに入れることでトークンをキャプチャしないことを決定できます。この段階では、トークンタイプのみを操作でき、トークンの値は操作できません。文法を指定したら、でコンパイルする必要があり$grammar->precomputeます。
INIT {
$grammar = Marpa::R2::Grammar->new({
actions => "MyActions", # a package name
default_action => 'first_arg',
source => \(<<'END_OF_GRAMMAR'),
:start ::= Value
Value ::= Bool action => doBool
| Number # use auto-action
| String # use auto-action
|| Array
|| Struct
Struct ::= Ident (LCurly) PairList (RCurly) action => doStruct
| (LCurly) PairList (RCurly) action => doStruct1
Array ::= Ident (LCurly) ItemList (RCurly) action => doArray
| (LCurly) ItemList (RCurly) action => doArray1
ItemList::= Value + separator => Comma action => doList
PairList::= Pair + separator => Comma action => doList
Pair ::= Ident (Equal) Value action => doPair
END_OF_GRAMMAR
});
$grammar->precompute;
}
上記はINITブロック内にあるため、実行される前に実行さparseれます。
今、私たちの行動が来ます。各アクションは、最初の引数としてアクションオブジェクトを使用して呼び出されますが、これは必要ありません（より高度な解析手法に役立ちます）。他の引数は、一致したトークン/ルールの値（タイプではない）です。これらのほとんどは、引数を破棄またはパックするか、後で定義されたオブジェクト内にデータを配置します。
sub MyActions::first_arg {
say STDERR "rule default action" if DEBUG;
my (undef, $first) = @_;
return $first;
}
sub MyActions::doStruct {
say STDERR "rule Struct" if DEBUG;
my (undef, $ident, $pair_list) = @_;
my %hash;
for (@$pair_list) {
my ($k, $v) = @$_;
$hash{$k} = $v;
}
return MyHash->new($ident, \%hash);
}
sub MyActions::doStruct1 {
say STDERR "rule Struct sans Ident" if DEBUG;
my (undef, $pair_list) = @_;
return MyActions::doStruct(undef, undef, $pair_list);
}
sub MyActions::doArray {
say STDERR "rule Array" if DEBUG;
my (undef, $ident, $items) = @_;
return MyArray->new($ident, $items);
}
sub MyActions::doArray1 {
say STDERR "rule Array sans Ident" if DEBUG;
my (undef, $items) = @_;
MyActions::doArray(undef, undef, $items);
}
sub MyActions::doList {
say STDERR "List" if DEBUG;
my (undef, @list) = @_;
return \@list;
}
sub MyActions::doPair {
say STDERR "Pair" if DEBUG;
my (undef, $key, $value) = @_;
return [$key, $value];
}
sub MyActions::doBool {
say STDERR "Bool" if DEBUG;
my (undef, $bool) = @_;
return MyBool->new($bool);
}
それはかなり見苦しいものでした。これらの特別なオブジェクトが必要なのは、（a）後で正しい形式に文字列化されるため、および（b）カーリーの前に型や名前ではないものを関連付けることができるためです。（そして（c）、Perlにはブール型がありません。これをオーバーライドする必要があります）。
最初に2つのヘルパーが来ます：$My::Indentプリントアウトがインデントされるスペースの数を設定します。はMy::stringifyHelper、オブジェクトが文字列表現に強制変換され、文字列（数値以外のすべて）が引用符で囲まれていることを確認します。
INIT{ $My::Indent = 4 }
sub My::stringifyHelper {
my (@objects) = @_;
for (@objects) {
if (ref $_) {
$_ = "$_";
} elsif ( not /\A-?\d+(?:\.\d+)?\z/) {
$_ = qq("$_");
}
}
return @objects;
}
ここにMyHashタイプがあります。文字列化コードは醜いですが、動作しているようです→誤ってプログラミングします。
{
package MyHash;
sub new {
my ($class, $type, $hashref) = @_;
bless [$type, $hashref] => $class;
}
sub type {
my ($self) = @_;
return $self->[0];
}
sub hash {
my ($self) = @_;
return $self->[1];
}
sub asString {
my ($self) = @_;
my @keys = sort keys %{ $self->hash };
my @vals =
map { s/\n\K/" "x$My::Indent/meg; $_ }
My::stringifyHelper @{ $self->hash }{@keys};
my $string = "";
for my $i (0 .. $#keys) {
$string .= (" "x$My::Indent) . "$keys[$i] = $vals[$i],\n";
}
return +($self->type // "") . "{\n$string}";
}
use overload
'""' => \&asString,
'%{}' => \&hash,
fallback => 1;
}
これはを実装しMyArrayます。文字列化は少し醜いですが、私はオブジェクトをハッシュとして表します。overload実際の配列にアクセスするときに再発しないようにするのに十分な知識がありません。
{
package MyArray;
sub new {
my ($class, $type, $aryref) = @_;
bless { type => $type, array => $aryref } => $class;
}
sub type {
my ($self) = @_;
return $self->{type};
}
sub array {
my ($self) = @_;
no overload;
return $self->{array};
}
sub asString {
my ($self) = @_;
my @els = My::stringifyHelper @{$self->array};
my $string = $self->type // "";
if (@els <= 1) {
$string .= "{ @els, }";
} else {
my $els = join '', map "$_,\n", @els;
$els =~ s/^/" "x$My::Indent/meg;
$string .= "{\n$els}";
}
return $string;
}
use overload
'""' => \&asString,
'@{}' => \&array,
fallback => 1;
}
今、小さなMyBool実装。ブール値のように機能するはずです:)
{
package MyBool;
sub new {
my ($class, $str) = @_;
my $bool;
if ('true' eq lc $str) { $bool = 1 }
elsif ('false' eq lc $str) { $bool = undef }
else { die "Don't know if $str is true or false" }
bless \$bool => $class;
}
use overload
'bool' => sub {
my ($self) = @_;
return $$self;
},
'""' => sub {
my ($self) = @_;
$$self ? 'true' : 'false';
},
fallback => 1;
}
これでほぼ完成です。ここに来るmain：
sub main {
local $/;
my $data = <DATA>;
my $dsc = parse($data);
say "/:";
say $dsc;
say "/Tools:";
say $dsc->{Tools};
say "/Tools/ShadowDensity/:";
say $dsc->{Tools}{ShadowDensity};
say "/Tools/ShadowDensity/Inputs/:";
say $dsc->{Tools}{ShadowDensity}{Inputs};
return 0;
}
これにより、データがロードおよび解析されます。次に、オブジェクト全体と特定の部分のみを印刷します。これは今のところうまくいくようです。
注：入力として提供したデータに対してパーサーを実行すると、失敗します。トークン化は成功しますが、どこかで閉じ中括弧を忘れました。それを修正した後、それは動作するはずです。
Todo：
- 一部のパーツ
exit 1は、例外がスローされる場所で使用されます。
- 上記のアクセスは機能しますが、他のパスは失敗します（undefを返します）。どこかにバグがあり、修正する必要がありますが、私にはわかりません。
- より良いエラーメッセージは素晴らしいでしょう、そしてデバッグレベルのより多くの多様性。