File Coverage

blib/lib/Wraith.pm

Criterion	Covered	Total	%
statement	99	100	99.0
branch	13	16	81.2
condition			n/a
subroutine	33	33	100.0
pod	0	14	0.0
total	145	163	88.9

use strict;
use warnings;

require Exporter;

our $VERSION = 0.12;

{
    package Wraith;

    our @ISA = qw( Exporter );
    our @EXPORT_OK = qw( $literal $literals $token $many $succeed $fail $many_g $opt $satisfy );

    {
        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
    }

    sub concat_impl {
        my @list_of_lists = @_;
        my @list;

        for my $elt (@list_of_lists) {
            push @list, $_ for @$elt;
        }
        \@list
    };
    our $concat = \&concat_impl;

    sub succeed_impl {
        my $v = $_[0];
        bless
        sub {
            my $u = (ref($v) eq "ARRAY") ? $v : [ $v ];
            [ [ $u, $_[0] ] ]
        }
    };
    our $succeed = bless \&succeed_impl;

    sub fail_impl {
        []
    };
    our $fail = bless \&fail_impl;

    sub satisfy_impl {
        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 $satisfy = bless \&satisfy_impl;

    sub literal_impl {
        my $y = $_[0];
        $satisfy->(
            sub {
                $y eq $_[0]
            }
        )
    };
    our $literal = bless \&literal_impl;

    sub literals_impl {
        my $y = $_[0];
        $satisfy->(
            sub {
                index($y, $_[0]) != -1
            }
        )
    };
    our $literals = bless \&literals_impl;

    sub token_impl {
        my ($tok, $skip) = @_;
        $skip = '\s*' if not $skip;
        $satisfy->(
            sub { 1 },
            sub {
                $_[0] =~ /^$skip($tok)(.*)/s
            }
        )
    };
    our $token = bless \&token_impl;

    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], $finpair->[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;

    sub many_g_impl {
        my $arglist = \@_;
        bless
        sub {
            my ($p) = deref($arglist->[0]);
            my $inp = $_[0];
            my $finlist = [];
            while (1) {
                my $reslist = $p->($inp);
                last if (not @$reslist);
                my $respair = shift @$reslist;
                for my $elt (@$reslist) {
                    $respair = $elt if (length($respair->[1]) < length($elt->[1]));
                }
                push @$finlist, $respair->[0];
                $inp = $respair->[1];
            }
            [ [ $concat->(@$finlist), $inp ] ]
        }
    }
    our $many_g = bless \&many_g_impl;

    sub opt_impl {
        my ($p) = deref($_[0]);
        $alt->($p, $succeed->( [] ))
    }
    our $opt = bless \&opt_impl;
}

{
    package Wraith_rule;

    our @ISA = qw( Exporter Wraith );
    our @EXPORT_OK = qw( );

    sub makerule {
        bless $_[0]
    }

    sub makerules {
        my ($class, @args) = @_;
        for my $elt (@args) {
            $elt = makerule($elt);
        }
        @args
    }
}

1;

__END__