File Coverage

blib/lib/Parser/Combinators.pm

Criterion	Covered	Total	%
statement	275	392	70.1
branch	116	214	54.2
condition	2	3	66.6
subroutine	36	53	67.9
pod	0	28	0.0
total	429	690	62.1

package Parser::Combinators;

use strict;
use 5.008_005;
our $VERSION = '0.03';

use Exporter 'import';

@Parser::Combinators::EXPORT    = qw(
        sequence
        choice
        try
        maybe
        regex
        parens
        char
        sepBy
        oneOf
        word
        natural
        symbol
        greedyUpto
        upto
        many
        many1
        whiteSpace
		comma
		matches
		unwrap
		empty
        getParseTree
        bindP
        returnP
        $V
        );

use Data::Dumper;
$Data::Dumper::Indent=0;
$Data::Dumper::Terse =1;
our $V= 0;

# I want to write the parser using lists, because sequencing is the most common operation.
# So I need a function to generate the actual parser from the lists
# which is actually a sequence of parsers
# The first arg is a list ref, the second arg is an optional code ref to process the returned list of matches
sub sequence {
    (my $plst, my $proc)=@_;
    my $gen = sub {
        (my $str)=@_;
		print "* sequence($str)\n" if $V;
        my $matches=[];
        my $st=1;
        my $str2='';
        my $ms=undef;
        for my $p (@{$plst}) {
            if (ref($p) eq 'CODE') {
                ($st, $str, $ms)=$p->($str);
            } elsif (ref($p) eq 'HASH') {
                my %hp=%{$p};
                (my $k, my $pp) = each %hp;
                ($st, $str, my $mms)=$pp->($str);
                $ms = {$k => $mms};
            } else { # assuming it's ARRAY
                my $p2 = sequence($p);
                ($st, $str, $ms)=$p2->($str)
            }
            if (!$st) {
                return (0,$str,[]);
            }
            push @{$matches},$ms;# if scalar @{ $ms };
        }
        if (defined($proc)) {
            if( ref($proc) eq 'CODE') {
                return (1,$str,$proc->($matches));
            } else {
                print 'TROUBLE: <',Dumper($plst),'><',Dumper($proc),'>' if $V;
                return (1,$str,$matches);
            }
        } else {
            return (1,$str,$matches)
        }
    };
    return $gen;
}

# In the best tradition, bind() and return()
sub bindP {
    (my $p1,my $p2) =@_;
    my $gen = sub {(my $str1) =@_;
        print "* bindP( \'$str1\' )\n" if $V;
        my $matches=undef;
        (my $st1,my $str2,my $m1) = $p1->( $str1 );
        push @{$matches},$m1;
        if ($st1) {
            print "bind: p1( $str1 ) matched,[$m1] try p2( $str2 )\n";
            (my $st2,my $str3, my $m2) = $p2->( $str2 );
           if(ref($m2) eq 'ARRAY' ){
                $matches =[ @{$matches},@{$m2} ];
            } elsif (defined $m2) {
                push @{$matches},$m2;
            }
            return ($st2,$str3,$matches);
        } else {
            return (0,$str1,undef);
        }
    };
    return $gen;
}

# Only we can't call it 'return' so let's call it enter :-)
sub returnP {
    sub {
        (my $str) = @_;
        return (0,$str,undef);
    }
}

# Choice: try every parser in the list until one succeeds or return fail.  '<|>' in Parsec
sub choice {
    my @parsers=@_;
    my $gen = sub {	(my $str)= @_;
		print "* choice('$str')\n" if $V;
        for my $p (@parsers) {
            my $status=0; my $matches=[];
            if (ref($p) eq 'CODE') {
                ($status, $str, $matches)=$p->($str);
            } elsif (ref($p) eq 'HASH') {
                my %hp = %{$p};
                (my $k, my $pp) = each %hp;
                ($status, $str, my $mms)=$pp->($str);
                $matches = {$k => $mms};
            } else {
                die Dumper($p);
            }
            if ($status) {
                print "choice: remainder => <$str>\n" if $V;
                print "choice: matches => [".Dumper($matches)."]\n" if $V;
                return ($status, $str, $matches);
            }
        }
        return (0, $str, []);
    };
    return $gen;
}
# Normally, when a parser parses a string, it removes the portion that matched. If you want to keep the string, wrap the parser in try()
sub try {
    (my $p)=@_;
    my $gen = sub {
        (my $str)=@_;
		print "* try( '$str' )\n" if $V;
        (my $status, my $rest, my $matches)=$p->($str);
        if ($status) {
            print "try: remainder => <$rest>\n" if $V;
            print "try: matches => [".Dumper($matches)."]\n" if $V;
            return (1, $rest, $matches);
        } else {
            print "try: match failed => <$str>\n" if $V;
            return (0, $str, $matches);
        }
    };
    return $gen;
}

# maybe() is like try() but always succeeds
# it returns the matches and the consumed string or the orig string and no matches
sub maybe {
    (my $p)=@_;
    my $gen = sub {
        (my $str)=@_;
		print "* maybe('$str')\n" if $V;
        (my $status, my $rest, my $matches)=$p->($str);
        if ($status) {
            print "maybe matches: [".Dumper($matches)."]\n" if $V;
            return (1, $rest, $matches);
        } else {
            print "maybe: no matches for <$str>\n" if $V;
            return (1, $str, undef);
        }
    };
    return $gen;
}

# Enough rope: this parser will parse whatever the regex is, stripping trailing whitespace
sub regex {
    (my $regex_str) = @_;
    my $gen = sub {
        (my $str)=@_;
        print "* regex( '/$regex_str/', '$str' )\n" if $V;
        my $matches=undef;
        if(
                $str=~s/($regex_str)\s*//
          ) {
            my $m=$1;
            $matches=$m;
            print "regex: remainder => <$str>\n" if $V;
            print "regex: matches => [$matches]\n" if $V;
            return (1,$str, $matches);
        } else {
            print "regex: match failed => <$str>\n" if $V;
        }
        return (0,$str, $matches); # assumes $status is 0|1, $str is string, $matches is [string]
    };
    return $gen;
}

sub parens {
    (my $ref)= @_;
    my $gen = sub {	(my $str)=@_;
		print "* parens($str)\n" if $V;
        my $matches=undef;
        (my $status, my $str, my $ch)=char('(')->($str);
        if ($status==1) {
            $str=~s/\s*//;
            (my $st,$str,$matches)=$ref->($str);
            print "parens: remainder => <$str>\n" if $V;
            print "parens: matches => [".Dumper($matches)."]\n" if $V;
            $status*=$st;
            if ($status==1) {
                (my $st, $str, my $ch)=char(')')->($str);
                if ($st==1) {
                    $str=~s/\s*//;
                }
                $status*=$st;
                if ($status==1) { # OK!
                    print "parens: matches => ".Dumper($matches)."\n" if $V;
                    return (1,$str, $matches);
                } else { # parse failed on closing paren
                    return (0,$str, $matches);
                }
            } else { # parse failed on $ref
                return (0,$str, $matches);
            }
        } else { # parse failed on opening paren
            return (0,$str,undef);
        }
    };
    return $gen;
}

sub char {
    (my $ch)=@_;
    my $gen =  sub {
        (my $str)=@_;
        print "* char('$ch', '$str')\n" if $V;
        if (substr($str,0,1) eq $ch) {
            print "char: matched \'$ch\' \n" if $V;
			print "char: remainder <".substr($str,1).">\n" if $V;
            return (1,substr($str,1),$ch);
        } else {
            return (0,$str,undef);
        }
    };
    return $gen;
}

sub sepBy {
    (my $sep, my $ref)=@_;
    my $gen = sub {	(my $str)=@_;
		 print "* sepBy('$sep', '$str')\n" if $V;
        my $matches=[];
        (my $status,$str,my $m)=$ref->($str);
        if ($status) {
            push @{$matches},$m;
            print "sepBy: remainder => <$str>\n" if $V;
            while( do {($status,$str,$m)=char($sep)->($str);
                    if ($status) {$str=~s/\s*//;};
                    $status==1} ) {
                (my $st,$str,$m)=$ref->($str);
                push @{$matches},$m;
            }
            print "sepBy matches => [".Dumper($matches)."]\n" if $V;
        } else { # first match failed.
            return (0,$str,undef);
        }
        return (1, $str, $matches);
    };
    return $gen;
}
# This is a lexeme parser, so it skips trailing whitespace
sub word {
    my $gen = sub {
        (my $str)=@_;
		print "* word( '$str' )\n" if $V;
        my $status=0;
        if(
                $str=~/^(\w+)/
          ) {
            my $m=$1;
            my $matches=$m;
            $status=1;
            $str=~s/^$m\s*//;
            print "word: remainder => <$str>\n" if $V;
            print "word: matches => [$matches]\n" if $V;
            return ($status,$str, $matches);
        } else {
            print "word: match failed => <$str>\n" if $V;
            return ($status,$str, undef); # assumes $status is 0|1, $str is string, $matches is [string]
        }
    };
    return $gen;
}
# matches an unsigned integer
sub natural {
    my $gen = sub {
        (my $str)=@_;
        print "* natural( '$str' )\n" if $V;
        my $status=0;
        if(
                $str=~/^(\d+)/
          ) {
            my $m=$1;
            my $matches=$m;
            $status=1;
            $str=~s/^$m\s*//;
            print "natural: remainder => <$str>\n" if $V;
            print "natural: matches => [$matches]\n" if $V;
            return ($status,$str, $matches);
        } else {
            print "natural: match failed => <$str>\n" if $V;
            return ($status,$str, undef); # assumes $status is 0|1, $str is string, $matches is [string]
        }
    };
    return $gen;
}

# As in Parsec, parses a literal and removes trailing whitespace
sub symbol {
    (my $lit_str) = @_;
    $lit_str=~s/(\W)/\\$1/g;
    my $gen = sub {
        (my $str)=@_;
        print "* symbol( '$lit_str', '$str' )\n" if $V;
        my $status=0;
        if(
                $str=~/^\s*$lit_str\s*/
          ) {
            my $m=$1;
            my $matches=$lit_str;
            $status=1;
            $str=~s/^\s*$lit_str\s*//;
            print "symbol: remainder => <$str>\n" if $V;
            print "symbol: matches => [$matches]\n" if $V;
            return ($status,$str, $matches);
        } else {
            print "symbol: match failed => <$str>\n" if $V;
            return ($status,$str, undef);
        }
    };
    return $gen;
}

# This parser parses anything up to the last occurence ofa given literal and trailing whitespace
sub greedyUpto {
    (my $lit_str) = @_;
    $lit_str=~s/(\W)/\\$1/g;
    my $gen = sub {
        (my $str)=@_;
        print "* greedyUpto( \'$lit_str\', \'$str\' )\n" if $V;
        if(
                $str=~/^(.*)\s*$lit_str\s*/
          ) {
            my $m=$1;
            $m=~s/\s*$//;
            my $matches= $m eq '' ? undef : $m;
            $str=~s/^.*$lit_str\s*//;
            print "greedyUpto: remainder => <$str>\n" if $V;
            print "greedyUpto: matches => [$matches]\n" if $V;
            return (1,$str, $matches);
        } else {
            print "greedyUpto: match failed => <$str>\n" if $V;
            return (0,$str, undef);
        }
    };
    return $gen;
}

# This parser parses anything up to the last occurence of a given literal and trailing whitespace
sub upto {
    (my $lit_str )= @_;
    $lit_str=~s/(\W)/\\$1/g;
    my $gen = sub {
        (my $str)=@_;
        print "upto1 \'$lit_str\': <$str>\n" if $V;
        if(
                $str=~/^(.*?)\s*$lit_str\s*/
          ) {
            my $m=$1;
            my $matches= $m eq '' ? undef : $m;
            $str=~s/^.*?$lit_str\s*//;
            print "upto: remainder => <$str>\n" if $V;
            print "upto: matches => [$matches]\n" if $V;
            return (1,$str, $matches);
        } else {
            print "upto: match failed => <$str>\n" if $V;
            return (0,$str, undef);
        }
    };
    return $gen;
}


# `many`, as in Parsec, parses 0 or more the specified parsers
sub many {
    (my $parser) = @_;
    my $gen = sub {
        (my $str)=@_;
        print "* many( '$str' )\n" if $V;
        (my $status,$str,my $m)=$parser->($str);
        if ($status) {
            my $matches = [$m];
            while( $status==1 ) {
                (my $st,$str,$m)=$parser->($str);
                push @{$matches},$m;
            }
            print "many: remainder => <$str>\n" if $V;
            print "many: matches => [".Dumper($matches)."]\n" if $V;
            return (1, $str, $matches);
        } else { # first match failed.
            print "many: first match failed => <$str>\n" if $V;
            return (1, $str,undef);
        }
    };
    return $gen;
}

# `many1`, as in Parsec, parses 1 or more the specified parsers
sub many1 {
    (my $parser) = @_;
    my $gen = sub {
        (my $str)=@_;
        my $matches=[];
        print "* many( '$str' )\n" if $V;
        (my $status,$str,my $m)=$parser->($str);
        if ($status) {
            push @{$matches},$m;
            while( $status==1 ) {
                (my $st,$str,$m)=$parser->($str);
                push @{$matches},$m;
            }
            print "many: remainder => <$str>\n" if $V;
            print "many: matches => [".Dumper($matches)."]\n" if $V;
        } else { # first match failed.
            print "many: first match failed => <$str>\n" if $V;
            return (0, $str,undef);
        }
        return (1, $str, $matches);
    };
    return $gen;
}

sub comma {
    my $gen = sub { (my $str) = @_;
		print "* comma( '$str' )\n" if $V;
        my $st = ($str=~s/^\s*,\s*//);
        if ($st) {
            print "comma: match\n" if $V;
        } else {
            print "comma: match failed\n" if $V;
        }
        return ($st, $str, undef);
    };
    return $gen;
}

sub semi {
    my $gen = sub { (my $str) = @_;
		print "* semi( '$str' )\n" if $V;
        my $st = ($str=~s/^\s*;\s*//);
        return ($st, $str, undef);
    };
    return $gen;
}



# strip leading whitespace, always success
sub whiteSpace {
    my $gen = sub {
        (my $str)=@_;
        print "* whiteSpace( \'$str\' )\n" if $V;
        $str=~s/^(\s*)//;
        my $m=$1;
        return (1,$str,$m)
    };
    return $gen;
}

sub oneOf {
    (my $patt_lst) = @_;
    my $gen = sub {
	(my $str)= @_;
		print "* oneOf([".join('|',@{$patt_lst})."],'$str')\n" if $V;
        for my $p (@{$patt_lst}) {
            (my $status, $str, my $matches)= symbol($p)->($str);
            if ($status) {
                print "choice: remainder => <$str>\n" if $V;
                print "choice: matches => [".Dumper($matches)."]\n" if $V;
                return (1, $str, $matches);
            }
        }
        return (0, $str, undef);
    };
    return $gen;
}

sub matches {
	return @{$_[0]};
}

sub unwrap {
	(my $elt_in_array)=@_;
	my $elt = shift @{$elt_in_array};
		return $elt;
}

sub empty {
	(my $elt_in_array)=@_;
	return (@{$elt_in_array} ) ? 0 : 1;
}

# This function returns labeled items in the parse tree.
# It is rather aggressive in removing unlabeled items
sub get_tree_as_lists { (my $list) = @_;
    my $hlist=[];
    for my $elt (@{$list}) {
        if (ref($elt) eq 'ARRAY' and scalar @{$elt}>0) { # non-empty list
            push @{ $hlist }, get_tree_as_lists($elt);
        } elsif (ref($elt) eq 'HASH') { # hash: need to process the rhs of the pair
            (my $k, my $v) = each %{$elt};
            if (ref($v) ne 'ARRAY') { # not an array => wrap in array and redo
                 push @{$hlist}, {$k => $v};
            } elsif (@{$v}==1) { # a single-elt array
                push @{$hlist}, {$k => $v->[0]};
            } else {
                my $pv =[
                    map {
                        if (ref($_) eq 'ARRAY') {
                            get_tree_as_lists($_)
                        } elsif ( ref($_) eq 'HASH') {
                            get_tree_as_lists([$_])
                        } elsif (defined $_) { $_ }
                    } @{$v}
                ];
                push @{$hlist}, {$k => $pv};
            }
        }
    }
    return scalar @{$hlist}==1 ? $hlist->[0] : $hlist;
}

sub is_list_of_objects { (my $mlo) =$_;
    if (ref($mlo) eq 'ARRAY') {
        my @tmlo=@{$mlo};
    my @l=grep { ref($_) ne 'HASH' } @tmlo;
    return scalar(@l)?0:1;
    } else {
        return 0;
    }
}

sub l2m { (my $hlist) =@_;
        my $hmap = {};
        my @hmap_vals = map {  (my $k, my $v)=%{$_}; $v } @{$hlist};
        my @hmap_keys = map {  (my $k, my $v)=%{$_}; $k } @{$hlist};
        my @hmap_rvals = map { is_list_of_objects($_) ? l2m($_) : $_ } @hmap_vals;
#        my @hmap_keys_vals = map {  each %{$_} } @{$hlist}
        for my $k ( @hmap_keys ) {
            my $rv = shift @hmap_rvals;
            $hmap->{$k}=$rv;
        }
#        my %{$hmap} = @hmap_keys_vals;
        return $hmap;
}



sub getParseTree { (my $m) =@_;
    return l2m(get_tree_as_lists($m));
}
#    return ( (hlist.length==1) ? (head hlist) : hlist) # This just returns 'false' ...

1;

__END__