#!/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;
}
[download]