LazyMap.pm

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;