Hello fellow monks,
While there is already Parser::Combinators on CPAN, I write a simple parser combinator demo whose idea is mainly from Hutton92 (Graham Hutton, HigherOrder Functions for Parsing, Journal of Functional Programming 2(3):323–343, July 1992). I try to make it look like boost.spirit  especially the sequence combinator ('then'), the alternative combinator ('alt') and the semantic action combinator ('using').
Here is the code of combinators:
{ package wraith; { package inner_lazy; sub TIESCALAR { my ($class, $val) = @_; bless $_[1], $class } sub FETCH { my ($self) = @_; $self>() } } use overload '>>' => "then_impl", '' => "alt_impl", '**' => "using_impl"; sub deref { my @args = @_; for my $elt (@args) { if (ref($elt) eq "wraith_rule") { $elt = $$elt; } } @args } our $concat = sub { my @list_of_lists = @_; my @list; for my $elt (@list_of_lists) { push @list, $_ for @$elt; } \@list }; our $succeed = bless sub { my $v = $_[0]; bless sub { my $u = (ref($v) eq "ARRAY") ? $v : [ $v ]; [ [ $u, $_[0] ] ] } }; our $fail = bless sub { [] }; our $satisfy = bless sub { my ($p, $m) = @_; $m = sub { $_[0] =~ /(.)(.*)/s } if not $m; bless sub { if (my ($x, $xs) = $m>($_[0])) { if ($p>($x)) { return $succeed>($x)>($xs); } else { return $fail>($xs); } } else { return $fail>( [] ); } } }; our $literal = bless sub { my $y = $_[0]; $satisfy>( sub { $y eq $_[0] } ) }; our $literals = bless sub { my $y = $_[0]; $satisfy>( sub { index($y, $_[0]) != 1 } ) }; our $token = bless sub { my ($tok, $skip) = @_; $skip = '\s*' if not $skip; $satisfy>( sub { 1 }, sub { $_[0] =~ /^$skip($tok)(.*)/s } ) }; sub alt_impl { my ($p1_, $p2_, $discard) = @_; bless sub { my ($p1, $p2) = deref($p1_, $p2_); my $inp = $_[0]; $concat>($p1>($inp), $p2>($inp)) } } our $alt = bless \&alt_impl; sub then_impl { my $arglist = \@_; bless sub { my ($p1) = deref($arglist>[0]); my $inp = $_[0]; my $reslist1 = $p1>($inp); my $finlist = []; for my $respair (@$reslist1) { my ($p2) = deref($arglist>[1]); my $reslist2 = $p2>($respair>[1]); for my $finpair (@$reslist2) { push @$finlist, [ $concat>($respair>[0], $finpai +r>[0]), $finpair>[1] ]; } } $finlist } } our $then = bless \&then_impl; sub using_impl { my ($p_, $f, $discard) = @_; bless sub { my ($p) = deref($p_); my $inp = $_[0]; my $reslist = $p>($inp); my $finlist = []; for my $respair (@$reslist) { push @$finlist, [ $f>($respair>[0]), $respair>[1] ] +; } $finlist } } our $using = bless \&using_impl; sub many_impl { my $p = $_[0]; my $f; tie $f, "inner_lazy", sub { many_impl($p) }; $alt>($then>($p, $f), $succeed>( [] )) } our $many = bless \&many_impl; } { package wraith_rule; our @ISA = qw ( wraith ); sub makerule { bless $_[0] } sub makerules { my ($class, @args) = @_; for my $elt (@args) { $elt = makerule($elt); } @args } }
wraith_rule seems ugly. But I have to make it a subclass of the combinator class wraith for convenience of writing rules further. The idea of Hutton92 is not monadic nor memorized. Perhaps I will try those techniques later.
Below is a demo for using the combinators. It demonstrates a simply modified untyped lambda calculus language, which is later translated into perl snippets. It's good to see the great similarity between Perl and lambda calculus  except the eval order :D
# test case: a lambdacalculustoperl translator my %expr_root = ( "kind" => "list", "defn" => [], "term" => [] ); my $rootref = \%expr_root; my ($formlist, $form, $term, $varlist, $appterm, $aterm); wraith_rule>makerules(\$formlist, \$form, \$term, \$varlist, \$appter +m, \$aterm); $formlist = $wraith::many>(\$form); $form = ( (\$term >> $wraith::token>(';')) ** sub { [ { "kind" => "term", "body" => $_[0]>[0] } ] } )  ( ($wraith::token>('[AZaz_]+') >> $wraith::token>('=') >> +\$term >> $wraith::token>(';')) ** sub { [ { "kind" => "defn", "name" => $_[0]>[0], "body" => +$_[0]>[2] } ] } ); $term = ( (\$appterm) ** sub { [ { "kind" => "appl", "body" => $_[0]> +[0] } ] } )  ( ($wraith::token>('\\\\') >> \$varlist >> $wraith::token>(' +\.') >> \$term) ** sub { [ { "kind" => "abst", "para" => $_[0]>[1], "body" => +$_[0]>[3] } ] } ); $varlist = ($wraith::many>($wraith::token>('[AZaz_]+'))) ** sub { +[ $_[0] ] }; $appterm = ($wraith::many>(\$aterm)) ** sub { [ $_[0] ] }; $aterm = ( ($wraith::token>('\(') >> \$term >> $wraith::token>('\)') +) ** sub { [ { "kind" => "applterm", "body" => $_[0]>[1] } ] } )  ( ($wraith::token>('[AZaz_]+')) ** sub { [ { "kind" => "ap +plvar", "val" => $_[0]>[0] } ] } ); sub emitabst; sub emitappl; sub emitapplterm; sub emitapplvar; sub emitterm; sub emitdefn; my %emitmethods = ( "term" => \&emitterm, "defn" => \&emitdefn, "appl" => \&emitappl, "abst" => \&emitabst, "applterm" => \&emitapplterm, "applvar" => \&emitapplvar ); sub emitabst { my $abstref = $_[0]; my $params = $abstref>{"para"}; my $nparams = @$params; my $c_param = shift @$params; my $codefrag = undef; if ($nparams) { $codefrag .= "sub { my \$$c_param = \$_[0]; "; } if (@$params) { $codefrag .= emitabst($abstref); } else { $codefrag .= $emitmethods{$abstref>{"body"}>{"kind"}}>($abs +tref>{"body"}); } $codefrag.' }' } sub emitappl { my $applref = $_[0]; my $oplist = $applref>{"body"}; my $codefrag = undef; my $addparen = 0; while (@$oplist) { my $opitr = shift @$oplist; if ($addparen) { $codefrag .= '( '; } $codefrag .= $emitmethods{$opitr>{"kind"}}>($opitr); if ($addparen) { $codefrag .= ' )'; } if (@$oplist) { $codefrag .= '>'; $addparen = 1; } } $codefrag } sub emitapplterm { my $atermref = $_[0]; $emitmethods{$atermref>{"body"}>{"kind"}}>($atermref>{"body"}) } sub emitapplvar { my $varref = $_[0]; '$'. $varref>{"val"} } sub emitterm { my $termref = $_[0]; $emitmethods{$termref>{"body"}>{"kind"}}>($termref>{"body"}) } sub emitdefn { my $defnref = $_[0]; 'my $' . $defnref>{"name"} .' = '. $emitmethods{$defnref>{"body" +}>{"kind"}}>($defnref>{"body"}) .';' } my $res = $formlist>('true = \x y.x; x x y; Y = \f.(\x y.f (x x)) (\x + y. f (x x));'); for my $itr (@{$res>[0]>[0]}) { if ($itr>{"kind"} eq "term") { push $expr_root{"term"}, $itr; } else { push $expr_root{"defn"}, $itr; } } my ($defnlist, $termlist) = ($rootref>{"defn"}, $rootref>{"term"}); print "# defnlist: \n"; for my $defnitr (@$defnlist) { print emitdefn($defnitr); print "\n"; } print "# termlist: \n"; for my $termitr (@$termlist) { print emitterm($termitr); print "\n"; }
The complete code is available at https://github.com/Akvelog/alittlefive/blob/master/_5wraith.pl
Any advise is welcome. Feel free to correct any of my mistakes (especially usage of English for I am not a native speaker).
 update 
For people not familiar with parser combinators:
Parser combinators are functions which take a string and return a intermediate analysis result  AST, tuple, calculation result, .etc. Their parsing ability is slightly better than LL(1) parsers  they are able to process products with common prefix but still die on leftrecursive grammars.
The usage of combinators is quite simple: just rewrite the EBNF, replacing each symbol with a combinator (basic combinator or a compsite combinator generated by applying operators 'then', 'alt', 'many', .etc). The combinator corresponding to the start symbol of the grammar is the expected parser. Apply a string to the parser and there will be a list of analysis results:
( (result_1, input_left_1), (result_2, input_left_2), ... (result_n, input_left_n) )
where input_left_i is the unprocessed input string. Obiviously, the results with empty unprocessed input strings are correct. If the language is not ambiguous, there will be only one correct result.
Two of the wellknown parser combinator implementations are boost.spirit (c++) and parsec (haskell). Readers may found some interesting info or tutorials in their documentation.
People not familiar with lambda calculus may refer to http://perl.plover.com/lambda/ . This article demonstrates how Perl itself contains the (untyped) lambda calculus with code demo, essays and slides. Readers may found it interesting.
 update Sep 17 2013 
I made it a CPAN module Wraith. All suggestions and criticisms are welcome.


Replies are listed 'Best First'.  

Re: Simple Parser Combinator Implementation
by roboticus (Chancellor) on Sep 07, 2013 at 22:10 UTC  
by withering (Monk) on Sep 08, 2013 at 03:23 UTC  
Re: Simple Parser Combinator Implementation
by raiph (Chaplain) on Sep 12, 2013 at 15:23 UTC  
by withering (Monk) on Sep 16, 2013 at 08:14 UTC  
by raiph (Chaplain) on Sep 18, 2013 at 08:47 UTC 