Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
248 lines (224 sloc) 6.35 KB
package LazyMap;
use 5.010;
# LazyMap.pm
#
# Copyright 2007-2010, Larry Wall
#
# You may copy this software under the terms of the Artistic License,
# version 2.0 or later.
# LazyMap implements backtracking for the Cursor parsing engine. It does this
# in a very similar manner to the List monad in Haskell. Notionally, Cursor
# processes lists of all results, however only the first result is immediately
# calculated; the other results are suspended, and only generated when later
# code needs to refer to them. The standard operation on lazy objects is to
# map a function over them; this function can return other objects, or lazy
# objects which will be lazily flattened in the result.
# A lazy object has the iterator nature, and is destroyed by use. Lazy objects
# support two methods; iter returns the next value (or undef), the bool
# overload returns true if more values are available.
# Lazy values can be associated with transactions. These are used in lieu
# of stack unwinding to implement deep cut operators; when a deep cut is
# performed, values are set on the transaction object, causing further iteration
# (i.e. backtracking) to fail for associated lazies.
use strict;
use warnings;
no warnings 'recursion';
use Exporter;
our @ISA = 'Exporter';
our @EXPORT = qw(lazymap eager);
our $AUTOLOAD;
# Calling an unrecognized method on a lazy delegates to the shifted value, and
# additionally returns the rest...
sub AUTOLOAD {
(my $meth = $AUTOLOAD) =~ s/.*:://;
return if $meth eq 'DESTROY';
print STDERR "AUTOLOAD $meth\n";
my $self = shift;
if (my ($eager) = $self->iter) {
return $eager->$meth(@_), $self;
}
return ();
}
use overload 'bool' => 'true';
# A lazy map represents the lazy result of a concatenating map operation.
# As a microoptimization, we shorten field names for the benefit of strcmp.
#
# B: the function to call to transform each incoming value; it is called in
# list context and it should return multiple values to create a choice
# point. It can also return a lazy list, which is treated as a lazy
# choice point.
# C: The values which were generated by the last block call, if it returned
# >1 (since iter only removes one at a time, but they don't arrive that way)
# L: The values input to the map which have not yet been fed to the block
# N: Number of values so far returned - this is used to ignore cuts if we
# haven't delivered our first value yet (somewhat of a hack).
#
# Values returned by a LazyMap are expected to be cursors, or at least have
# an _xact field that can be checked for cutness.
# Construct a lazymap - block, then a list of inputs (concatenated if lazies)
sub new {
my $class = shift;
my $block = shift;
return bless { 'B' => $block, 'C' => [], 'L' => [@_], 'N' => 0 }, $class;
}
# The fundamental operation on lazies, sometimes spelled concatMap. In list
# context, returns the first value eagerly (this pairing is equivalent to the
# rolled lazymap in lazycat context).
sub lazymap (&@) {
my $block = shift;
return () unless @_;
my $lazy = bless { 'B' => $block, 'C' => [], 'L' => [@_], 'N' => 0 }, 'LazyMap';
if (wantarray) {
if (my @retval = iter($lazy)) {
push @retval, $lazy if @{$lazy->{C}} || @{$lazy->{L}};
return @retval;
}
return;
}
else {
$lazy;
}
}
# Destructively extract the next value from a lazy, or undef.
sub iter {
my $self = shift;
my $lazies = $self->{L};
my $called = $self->{C};
while (@$called or @$lazies) {
# pull from lazy list only when forced to
while (not @$called) {
return () unless @$lazies;
my $lazy = $$lazies[0];
# recursive lazies? delegate to lower ->iter
if (ref($lazy) =~ /^Lazy/) {
my $todo = $lazy->iter;
if (defined $todo) {
@$called = $self->{B}->($todo);
}
else {
shift @$lazies;
}
}
elsif (defined $lazy) { # just call our own block
@$called = $self->{B}->(shift @$lazies);
}
else { # undef snuck into the list somehow
shift @$lazies;
}
}
# evaluating the blocks may have returned something lazy, so delegate again
while (@$called and ref($$called[0]) =~ /^Lazy/) {
my $really = $$called[0]->iter;
if ($really) {
unshift @$called, $really;
}
else {
shift @$called;
}
}
# finally have at least one real cursor, grep for first with live transaction
while (@$called and ref($$called[0]) !~ /^Lazy/) {
my $candidate = shift @$called;
# make sure its transaction doesn't have a prior commitment
my $xact = $candidate->{_xact};
my $n = $self->{N}++;
return $candidate unless $xact->[-2] and $n;
}
}
return ();
}
sub true {
my $self = shift();
my $called = $self->{C};
return 1 if @$called;
my $lazies = $self->{L};
return 0 unless @$lazies;
return 0 unless my ($c) = $self->iter;
unshift(@$called, $c);
return 1;
}
# Destructively convert a lazies into a list; equivalently, places lazycat
# context on the interior. Only useful in list context
sub eager {
my @out;
while (@_) {
my $head = shift;
if (ref($head) eq 'LazyMap') { # don't unroll LazyConst
while (my ($next) = $head->iter) {
push @out, $next;
}
}
else {
push @out, $head;
}
}
# print STDERR ::Dump(@out);
@out;
}
# LazyConst produces an infinite list, which stubbornly tries the same value
# over and over
{ package LazyConst;
sub new {
my $self = shift;
my $xact = shift;
bless { 'K' => shift, 'X' => $xact }, 'LazyConst';
}
sub true {
1;
}
sub iter {
return () if $_[0]->{X}->[-2];
$_[0]->{K};
}
}
# LazyRange lazily produces each value in a sequence - useful for quantifiers
{ package LazyRange;
sub new {
my $class = shift;
my $xact = shift;
my $start = shift;
my $end = shift;
bless { 'N' => $start, 'E' => $end, 'X' => $xact }, $class;
}
sub true {
1;
}
sub iter {
my $self = shift;
if ($self->{X}->[-2]) {
()
}
elsif ((my $n = $self->{N}++) <= $self->{E}) {
$n;
}
else {
();
}
}
}
# Like above, but reverse
{ package LazyRangeRev;
sub new {
my $class = shift;
my $xact = shift;
my $start = shift;
my $end = shift;
bless { 'N' => $start, 'E' => $end, 'X' => $xact }, $class;
}
sub true {
1;
}
sub iter {
my $self = shift;
if ($self->{X}->[-2]) {
()
}
elsif ((my $n = $self->{N}--) >= $self->{E}) {
$n;
}
else {
();
}
}
}
1;
Something went wrong with that request. Please try again.