File Coverage

blib/lib/HOI/Match.pm

Criterion	Covered	Total	%
statement	69	70	98.5
branch	25	28	89.2
condition	8	12	66.6
subroutine	11	11	100.0
pod	1	4	25.0
total	114	125	91.2

package HOI::Match;

require Exporter;

use Parse::Lex;
use HOI::typeparser;

our @ISA = qw( Exporter );
our @EXPORT_OK = qw( pmatch );
our $VERSION = '0.071';

my @tokens = (
    qw (
        LPAREN      [\(]
        RPAREN      [\)]
        CONCAT      ::
        NIL         nil
        IDENT       [A-Za-z_][A-Za-z0-9_]*
        CONST       (?:0(?:\.[0-9]+)?)|(?:[1-9][0-9]*(?:\.[0-9]+)?)|(?:\".+\")|(?:\'.+\')
    ),
    COMMA => q/,/
);

my $lexer = Parse::Lex->new(@tokens);
$lexer->skip('\s+');
my $parser = HOI::typeparser->new();

sub lexana {
    my $token = $lexer->next;
    if (not $lexer->eoi) {
        return ($token->name, $token->text);
    } else {
        return ('', undef);
    }
}

my %compiled_patterns;

sub pcompile {
    $lexer->from(shift);
    $parser->YYParse(yylex => \&lexana)
}

sub astmatch {
    my ($ast, $args) = @_;
    return (0, {}) if ($#{$ast} ne $#{$args});
    my %switches = (
        "const" =>
        sub {
            my ($sym, $val) = @_;
            if( (substr($sym, 0, 1) eq '\'') or (substr($sym, 0, 1) eq '"') ) {
                my $quote = substr($sym, 0, 1);
                return ($sym eq $quote.$val.$quote) ? (1, {}) : (0, {});
            } else {
                return ($sym == $val) ? (1, {}) : (0, {});
            }
        },
        "any" =>
        sub {
            my ($sym, $val) = @_;
            (1, ((substr($sym, 0, 1) ne '_') ? { $sym => $val } : {}))
        },
        "list" =>
        sub {
            my ($l, $val) = @_;
            if (($#{$l} >= 0) and ($#{$val} >= 0)) {
                my ($s1, $r1) = astmatch([ $l->[0] ], [ $val->[0] ]);
                my ($s2, $r2) = astmatch([ $l->[1] ], [ [ @$val[1..$#{$val}] ] ]);
                return ($s1 * $s2, { %$r1, %$r2 });
            } elsif (($#{$l} < 0) and ($#{$val} < 0)) {
                return (1, {});
            } else {
                return (0, {});
            }
        },
        "adt" =>
        sub {
            my ($adt, $val) = @_;
            return (0, {}) if ((not defined $val->{"type"}) or (not defined $val->{"val"}));
            my ($sym, $typelist) = ($adt->[0], $adt->[1]);
            return (0, {}) if ($adt->[0] ne $val->{"type"});
            return (0, {}) if ($#{$adt->[1]} != $#{$val->{"val"}});
            astmatch($adt->[1], $val->{"val"})
        }
    );
    my $ret = {};
    for (my $idx = 0; $idx <= $#{$ast}; $idx++) {
        my ($status, $result) = $switches{$ast->[$idx]->{"kind"}}->($ast->[$idx]->{"val"}, $args->[$idx]);
        if ($status) {
            $ret = { %$ret, %$result };
        } else {
            return (0, {})
        }
    }
    (1, $ret)
}

sub pmatch {
    my $patterns = \@_;
    sub {
        my $args = \@_;
        while (@$patterns) {
            my $pattern = shift @$patterns;
            my $handler = shift @$patterns;
            my $pattern_sig = (caller(1))[3].$pattern;
            $compiled_patterns{$pattern_sig} = pcompile($pattern) if (not defined $compiled_patterns{$pattern_sig});
            my $pattern_ast = $compiled_patterns{$pattern_sig};
            my ($status, $results) = astmatch($pattern_ast, $args);
            if ($status) {
                my ($package) = caller(1);
                local $AttrPrefix = $package.'::';
                #attr $results;
                my $evalstr = '';
                for my $key (keys %$results) {
                    $evalstr .= 'local $'."$AttrPrefix"."$key".' = $results->{'."$key".'}; ';
                }
                return eval "{ $evalstr ".'$handler->(%$results); }';
            }
        }
        0
    }
}

1;
__END__