You inspired me to implement
monadic parser combinators in perl. I will probably document the thing better, but here you go. Grab
Monadic_parser and the corresponding needed module
Do_notation.pm.
For extra credit figure out a way to use perl's native regex engine instead of the roll-your-own kind used (i.e.
/\d*/ instead of
many(digits())). Maybe monads in perl aren't so useless after all.
#!/usr/bin/perl -w
# Monadic parser combinators in perl
# Ideas mostly 'borrowed' from paper
# _Monadic Parser Combinators_ by Graham Hutton and Erik Meijer
#
# Simple parser for integer arithmetic plus some other routines
# from paper which aren't used.
use strict;
use Data::Dumper;
use Do_notation;
my $question="1+2*3-4";
my $ans=parse()->($question);
print "\n$question = ".@$ans[0]->[0]."\n\n";
#print Dumper $ans; #dump the entire data structure to see what's hap
+pening.
#### Monadic Parser Combinator subroutines ####
sub parse
{
DO {
my $c <- expr();
Return($c);
}
}
### Try and implement the following BNF grammar ###
#
# expr ::= expr addop term | term
# term ::= term mulop factor | factor
# factor ::= digit | (expr)
# addop ::= +|-
# mulop ::= *|/
#
sub expr { chainl( term() )->( addop() ) }
sub term { chainl( factor() )->( mulop() ) }
sub factor { alternate( number() )->( grouped_op() ) }
sub addop { alternate(ch('+'))->(ch('-')) }
sub mulop { alternate(ch('*'))->(ch('/')) }
sub number { many1(digit()) }
sub digit { sat(sub{my $x=shift; return ('0' lt $x and $x lt '9');})
+}
sub grouped_op
{
DO {
$_ <- ch("(");
my $a <- expr();
$_ <- ch(")");
Return($a);
}
}
sub chainl
{
my $p = shift;
sub
{
my $op = shift;
DO {
my $a <- $p;
the_rest($a,$p,$op);
}
}
}
sub the_rest
{
my $a = shift; my $p=shift; my $op=shift;
alternate(DO {
my $f <- $op;
my $b <- $p;
the_rest(operation($f,$a,$b),$p,$op);
}
)->(Return($a));
}
sub operation
{
my %op =('+' => sub{ $_[0] + $_[1]},
'-' => sub{ $_[0] - $_[1]},
'*' => sub{ $_[0] * $_[1]},
'/' => sub{ $_[0] / $_[1]} );
my $o = shift;
$op{$o}->(@_);
}
sub many1
{
my $p = shift;
alternate(DO {
my $a <- $p;
my $as <- many1($p);
Return($a.$as);
}
)->($p);
}
sub many
{
my $p = shift;
alternate(many1($p))->(Return(""));
}
sub alternate
{
my $p = shift;
sub
{
my $q = shift;
sub
{
my $inp = shift;
my $t= $p->($inp);
my $u= $q->($inp);
my @copy = (@$t,@$u);
return \@copy;
}
}
}
sub ch
{
my $y = shift;
sat(sub{my $x=shift; return ($x eq $y);});
}
sub upper { sat(sub{my $x=shift; return ('A' lt $x and $x lt 'Z')}) }
sub lower { sat(sub{my $x=shift; return ('a' lt $x and $x lt 'z')}) }
sub letter { alternate(lower())->(upper()); }
sub sat
{
my $parser = shift;
Bind(item())->(sub{ my $x = shift;
my $q=$parser->($x);
if ($q)
{
return Return($x);
}else
{
return zero();
}
});
}
sub zero { sub { return [] } }
sub item
{
sub {
my $inp = $_[0];
if( (my $c, my $cs)=($inp=~/(.)(.*)/))
{
return [[$c,$cs]];
}
else
{
return [];
}
}
}
sub Return
{
my $val = shift;
sub {
my $state = $_[0];
[[$val, $state]]
}
}
sub Bind
{
my $func1 = $_[0];
sub {
my $func2 = $_[0];
sub {
my $initial_state=$_[0];
concat( map{
(my $a, my $next_state)=@$_;
($func2->($a))->($next_state)
} grep {$_} @{$func1->($initial_state)
+}
)
}
}
}
sub concat
{
my @lol=@_;
my @list;
for my $garbage (@lol)
{
push @list, $_ for @$garbage;
}
return \@list;
}
-- All code is 100% tested and functional unless otherwise noted.