# testing - 2nd order functions

package WWW::Extractor::Generic::Predicates;

use strict;
use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK %cache);

use Exporter;

@ISA = qw|Exporter|;

%EXPORT_TAGS = ( all=>[qw(And Or Not RECS RE PartCS Part EqCS
			  Eq Is True False Wrap PartWrap EqWrap Curry)],
		 cache=>[qw(%cache list_key)] );
Exporter::export_ok_tags(qw(all cache));

# the cache stores predicates that have already been requested,
# thus supporting 'flyweight' predicates
%cache = ();

# list_key returns a unique hash key for
# a list, based on the values
sub list_key {
    join "&",
    map { defined $_ ? $_ : "?" }
    map { my $a = $_; $a =~ s/([\\&?])/\\$1/g; $a } @_;
}

sub And {
    my @tests = map {PartWrap($_)} @_;
    return $cache{And}{list_key(@tests)} ||=
	sub {
	    for my $test (@tests) {
		return unless &$test(@_);
	    }
	    return 1;
	}
}

sub Or {
    my @tests = map {PartWrap($_)} @_;
    return $cache{Or}{list_key(@tests)} ||=
	sub {
	    for my $test (@tests) {
		return 1 if &$test(@_);
	    }
	    return;
	}
}

sub Not {
    my $test = PartWrap(shift);
    return $cache{list_key('Not', $test)} ||=
	sub {
	    return ! &$test(@_);
	}
}

sub RECS {
    my $pattern = shift;
    return $cache{RECS}{$pattern} ||=
	eval q{
	    sub {
		my $e = shift;
		return $e =~ /$pattern/o;
	    }
        };
# the eval, /o combination prevents the RE being processed every time
}

sub RE {
    my $pattern = shift;
    return RECS("(?i)$pattern");
}

sub PartCS {
    my $substr = shift;
    return $cache{PartCS}{$substr} ||=
	sub {
	    my $e = shift;
	    return index($e, $substr) > -1;
	}
}

sub Part {
    my $substr = lc shift;
    return $cache{Part}{$substr} ||=
	sub {
	    my $e = shift;
	    return index(lc $e, $substr) > -1;
	}
}

sub EqCS {
    my $str = shift;
    return $cache{EqCS}{$str} ||=
	sub {
	    my $e = shift;
	    return $e eq $str;
	}
}

sub Eq {
    my $str = lc shift;
    return $cache{Eq}{$str} ||=
	sub {
	    my $e = shift;
	    return lc $e eq $str;
	}
}

sub Is {
    my $str = shift;
    return $cache{Is}{$str} ||=
	sub {
	    my $e = trim(shift);
	    return $e eq $str;
	}
}

sub True {
    return $cache{True} ||=
	sub {
	    return 1;
	}
}

sub False {
    return $cache{False} ||=
	sub {
	    return;
	}
}

sub Wrap {
    my ($test, $wrap) = @_;

    my $ref = ref $test;
    if ($ref eq 'CODE') {
	# this test is already a function
	$test;
    } elsif ($ref) {
	# this test is an object to match
	Eq($test);
    } else {
	# this test is a string, to be wrapped in another (default) test
	&$wrap($test);
    }
}

sub PartWrap {
    my $test = shift;
    return Wrap($test, \&Part);
}

sub EqWrap {
    my $test = shift;
    return Wrap($test, \&Eq);
}

sub Curry {
    my ($fn, @curry_args) = @_;
    return sub {
	my @extra_args = @_;
	return &$fn(@curry_args, @extra_args);
    }
}

1