File Coverage

lib/List/Gen/Lazy.pm
Criterion Covered Total %
statement 122 183 66.6
branch 60 104 57.6
condition 14 29 48.2
subroutine 24 40 60.0
pod 2 8 25.0
total 222 364 60.9


line stmt bran cond sub pod time code
1             package List::Gen::Lazy;
2 1     1   23550 use lib '../../';
  1         3  
  1         6  
3 1     1   1575 use List::Gen ();
  1         3  
  1         143  
4             for my $method (qw(import VERSION)) {
5             *$method = sub {
6 1     1   10 splice @_, 0, 1, 'List::Gen';
7 1         2 goto &{List::Gen->can($method)}
  1         4  
8             }
9             }
10            
11             package
12             List::Gen;
13 1     1   9 use strict;
  1         2  
  1         32  
14 1     1   4 use warnings;
  1         1  
  1         32  
15 1     1   3 use Scalar::Util 'set_prototype';
  1         1  
  1         151  
16             our $LOOKAHEAD = 0;
17             push our @lazy_export, qw (lazy L lazyx Lx Lazy Lazyx lazypipe lazyflatten fn now stream);
18             push our (@EXPORT_OK), @lazy_export;
19             $List::Gen::EXPORT_TAGS{':lazy'} = \@lazy_export;
20 1     1   1023 no if $] > 5.012, warnings => 'illegalproto';
  1         8  
  1         5  
21            
22            
23             =head1 NAME
24            
25             List::Gen::Lazy - perl6 / haskell like laziness in perl5
26            
27             =head1 SYNOPSIS
28            
29             this module provides tools to implement perl6/haskell style lazy programming
30             in perl5.
31            
32             this module is a mixin to L that adds functions to C< List::Gen's >
33             namespace and exportable function list
34            
35             =head1 FUNCTIONS
36            
37             =over 8
38            
39             =item lazypipe C< LIST >
40            
41             C< lazypipe > provides a lazy list implementation that will expand generators.
42            
43             two methods are provided, C<< ->next >> which returns the next item from the
44             pipe, and C<< ->more >> which returns true if there are more items in the pipe.
45             the pipe works with aliases to its argument list, and never touches or copies
46             any items until it has to.
47            
48             C< lazypipe > provides the behavior of the C< lazy > generator.
49            
50             =item lazyflatten C< LIST >
51            
52             C< lazyflatten > is just like C< lazypipe > except it will also expand array
53             references and subroutines.
54            
55             C< lazyflatten > provides the behavior of the C< lazyx > generator.
56            
57             =item lazy C< LIST >
58            
59             =item L C< LIST >
60            
61             C< lazy > is a C< lazypipe > wrapped inside of an iterative generator.
62             if C< LIST > is one item, and is already a generator, that generator is
63             returned unchanged.
64            
65             =item lazyx C< LIST >
66            
67             =item Lx C< LIST >
68            
69             C< lazyx > is a C< lazyflatten > wrapped inside of an iterative generator.
70             if C< LIST > is one item, and is already a generator, that generator is
71             returned unchanged.
72            
73             =item fn C< CODE [ARITY] [RETURNS] >
74            
75             C< fn > converts a subroutine into a subroutine with partial application and
76             lazy evaluation.
77            
78             my $add3 = fn {$_[0] + $_[1] + $_[2]} 3;
79             my $add2 = $add3->(my $first);
80             my $add1 = $add2->(my $second);
81            
82             my $sum1 = $add1->(4);
83             my $sum2 = $add1->(8);
84             $first = 10;
85             $second = 100;
86             say $sum1; # prints 114
87            
88             $second = 800;
89             say $sum1; # still prints 114
90             say $sum2; # prints 818
91            
92             C< fn > supports subroutine prototypes, and can determine C< ARITY > from them.
93             C< ARITY > defaults to 1, with a prototype of C< (@) >. C< ARITY > can be given
94             as a prototype string C< '&@' > or an integer.
95            
96             the C< RETURNS > defaults to 1, and specifies the number of values that will
97             be returned by the function (the number of thunk accessors to create). for
98             example, the C< splitAt > function in L is implemented as:
99            
100             *splitAt = fn {take(@_), drop(@_)} 2, 2;
101            
102             my ($xs, $ys) = splitAt(3, <1..>); # 2 thunk accessors are created but
103             # take() and drop() have not been called
104             say $xs->str; # 1 2 3
105             say $ys->str(5); # 4 5 6 7 8
106            
107             due to partial application, you can even call subs in a way that looks a bit
108             like the haskell type signature, should you so desire.
109            
110             my ($xs, $ys) = splitAt -> (3) -> (<1..>);
111            
112             most of the functions in L are implemented with C< fn >
113            
114             =item now C< LIST >
115            
116             sometimes the return values of C< fn {...} > are too lazy. C< now > will force
117             the values in C< LIST > to evaluate, and will return the new list.
118            
119             now(...) ~~ grep {!$_ or 1} ...
120            
121             =item methods of C< fn {...} > functions
122            
123             return values of C< fn {...} > have the following overloaded behaviors and
124             methods
125            
126             $fn . $code $fn->compose($code) sub {$fn->(&$code)}
127             $fn << $val $fn->curry($val) sub {$fn->($val, @_)}
128             $fn >> $val $fn->rcurry($val) sub {$fn->(@_, $val)}
129             ~$fn $fn->flip sub {$fn->(@_[reverse 0 .. $#_])}
130            
131             some more complex examples, assuming the functions from L
132            
133             my $second = \&head . \&tail;
134            
135             my $third = \&head . \&tail . \&tail;
136            
137             my $join = \&foldl << sub {$_[0] . $_[1]};
138            
139             my $ucjoin = sub {uc $_[0]} . $join;
140            
141             my $cycle = \&cycle << '[' >> ']';
142            
143             my $joined_cycle = $ucjoin . take(18) . $cycle;
144            
145             say $joined_cycle->(qw(1 a 2 b)); # '[1A2B][1A2B][1A2B]'
146            
147             the overloaded operators for functions do not seem to work properly in perl's
148             before 5.10. the corresponding methods can be used instead.
149            
150             =cut
151            
152            
153             sub lazypipe {
154 3     3 0 158 my ($pipe, $pos, $size) = (\@_, 0, 0);
155 3         6 my ($fetch, $src, $mutable);
156             curse {
157             next => sub {
158 40     40   164 top: until ($size) {
159 14 100       29 @$pipe or return;
160 13         17 $src = shift @$pipe;
161 13 50       37 $src = $$src->() if ref $src eq 'List::Gen::Thunk';
162 13 100       30 ($size, $fetch) = isagen($src) ? do {
163 3   33     18 $mutable = $src->is_mutable && tied(@$src)->can('fsize');
164 3         14 ($src->size, tied(@$src)->can('FETCH'))
165             } : (1, undef)
166             }
167 39 100       63 if ($fetch) {
168 29         61 my $got = cap $fetch->(undef, $pos);
169 29 50       59 $size = $mutable->() if $mutable;
170 29 50       46 if ($size <= $pos) {
171 0         0 $size = $pos = 0;
172 0         0 goto top;
173             }
174 29 100       57 $size = $pos = 0 if ++$pos >= $size;
175 29 50       113 return wantarray ? @$got : pop @$got;
176             } else {
177 10         14 $size = 0;
178 10         47 return $src
179             }
180             },
181 26 100   26   107 more => sub {@$pipe or $pos < $size},
182 3         39 } => 'List::Gen::Pipe'
183             }
184            
185             sub lazyflatten {
186 3     3 0 353 my ($pipe, $pos, $size) = (\@_, 0, 0);
187 3         5 my ($type, $src, $ref, $mutable);
188             my $next = sub {
189 52     52   222 shift_pipe: until ($size) {
190 16 100       35 @$pipe or return;
191 15         22 $src = shift @$pipe;
192 15 50       42 $src = $$src->() if ref $src eq 'List::Gen::Thunk';
193 15         15 ($size, $type) = do {
194 15 100       105 if ($ref = ref $src) {
  10         33  
195 5 50       21 if ($ref eq 'ARRAY') {
    100          
    50          
196 0         0 (0 + @$src, 'array')
197             }
198 3         33 elsif (List::Gen::isagen $src) {
199 2         20 $mutable = tied(@$src)->mutable;
200 2         8 ($src->size, 'gen')
201             }
202 3         13 elsif (eval {$src->isa('List::Gen::Pipe')}) {
203 0         0 ($src->more, 'pipe')
204             }
205             else {1}
206             }
207             else {1}
208             }
209             }
210 51         51 my $got;
211 51 100       84 if ($type) {
212 20 50       45 if ($type eq 'array') {
    50          
213 0         0 $got = \$$src[$pos]
214             }
215             elsif ($type eq 'gen') {
216 20         42 $got = \$src->get($pos);
217 20 50       155 $size = $src->size if $mutable;
218 20 50       40 if ($pos >= $size) {
219             goto shift_pipe
220 0         0 }
221             }
222             else {
223 0         0 $got = \$src->next;
224 0         0 $size = $src->more
225             }
226             } else {
227 31 100       54 if ($ref eq 'CODE') {
  10         13  
228 21         47 defined ${$got = \$src->()}
229             ? $pos--
230 21 100       33 : do {
231 2         12 $pos = $size = 0;
232             goto shift_pipe
233 2         20 }
234             }
235             else {$got = \$src}
236             }
237 49 100       135 if (++$pos >= $size) {
238 12         17 $pos = $size = 0
239             }
240 49         127 $$got
241 3         17 };
242 31 100   31   126 curse {
243             next => $next,
244             more => sub {@$pipe or $pos < $size},
245 3         19 } => 'List::Gen::Pipe'
246             }
247            
248             my $lazy = sub {
249             my $pipe = shift;
250             $pipe->more or return empty;
251             iterate_multi {
252             my $x = cap $pipe->next;
253             $pipe->more or @$x ? done @$x : done;
254             @$x
255             }
256             };
257            
258             sub lazy {
259 2 100 66 2 1 18 if (@_ == 1 and ref $_[0]) {
260 1 50       4 return $_[0] if isagen $_[0];
261 0 0       0 return &makegen($_[0]) if ref $_[0] eq 'ARRAY';
262             }
263 1         4 $lazy->(&lazypipe)
264             }
265            
266 2 100 66 2 0 766 sub lazyx {@_ == 1 && ref $_[0] && isagen($_[0]) or $lazy->(&lazyflatten)}
      66        
267             BEGIN {
268 1     1   887 *L = *lazy;
269 1         1027 *Lx = *lazyx;
270             }
271 0     0 1 0 sub Lazy {$lazy->(&lazypipe)}
272 0     0 0 0 sub Lazyx {$lazy->(&lazyflatten)}
273            
274             my $set_proto = sub {bless set_prototype(\&{$_[1]}, $_[0]), 'List::Gen::Function'};
275            
276             my $fn = \&fn;
277             my ($proto_init, $proto_tail, $will_return);
278             our $proto_split;
279             {
280             my %will_return;
281             my $proto_chunk = qr/ \\? (?: [\%\@\*\$\&_]| \[ [^\]]+ \] ) /x;
282            
283             $proto_tail = sub {(my $proto = $_[0]) =~ s/^$proto_chunk//; $proto};
284             $proto_init = sub {
285             my ($head, $tail) = $_[0] =~ /^([^;]*)(;.*)?$/;
286             $head =~ s/($proto_chunk)$//;
287            
288             (($1 eq '@' and substr($head, -1) ne '@') or $1 eq '%')
289             ? $_[0]
290             : join('', grep defined, $head, $tail)
291             };
292             $proto_split = sub {$_[0] =~ /$proto_chunk/go};
293             $will_return = sub {$will_return{$_[0]} or 1};
294            
295             sub fn (&@) {
296 12     12 0 2930 my $code = shift;
297 12   100     37 my $proto = prototype($code) || '@';
298            
299 12         14 my $need;
300 12 100       37 if (@_) {
301 10 50 33     75 if (defined $_[0] and $_[0] =~ /^\d+$/) {
302 10         19 $need = shift;
303             } else {
304 0   0     0 $proto = shift || '@';
305             }
306             }
307            
308 12 100 50     39 my $returns = @_ ? shift : $will_return{$code} || 1;
309            
310 12 50       65 my ($head) = $proto =~ /^([^;]*)(?:;.*)?$/
311             or carp "unsupported prototype: $proto";
312            
313 12 100       32 unless (defined $need) {
314 2         13 $need = (()= $head =~ /$proto_chunk/go);
315             }
316 12 100 100     40 if ($need > 1 and $proto eq '@') {
317 1         4 $proto = ('@' x $need)
318             }
319 12         77 (my $next_proto = $proto) =~ s/^$proto_chunk//o;
320            
321 12         16 my $self;
322             $self = my $ret = $set_proto->($proto, sub {
323 19 50   19   1798 return $self unless @_;
324 19         32 my $args = \@_;
325            
326 19 100       59 if (@_ < $need) {
    50          
327 16     16   34 &fn ($set_proto->($next_proto,
328             sub {$code->(@$args, @_)}
329 8         34 ), $need - @_, $returns)
330             }
331             elsif (@_ >= $need) {
332 11     11   39 my $thunk = sub {$code->(@$args)};
  11         24  
333 11         12 my $data;
334 11 50       22 if ($returns == 1) {
335             bless \sub {
336 11 50   11   21 unless ($data) {
337 11         17 $data = \scalar $thunk->();
338 10 50       64 $data = \$$$data->() if ref $$data eq 'List::Gen::Thunk';
339 10         13 undef $thunk;
340             }
341 10         77 $$data
342 11         93 } => 'List::Gen::Thunk'
343             } else {
344 0         0 map {
345 0         0 my $n = $_ - 1;
346             bless \sub {
347 0 0   0   0 unless ($data) {
348 0 0       0 $data = sub {\@_}->(map {
  0         0  
349 0         0 ref eq 'List::Gen::Thunk' ? $$_->() : $_
350             } $thunk->());
351 0         0 undef $thunk;
352             }
353 0         0 $$data[$n]
354 0         0 } => 'List::Gen::Thunk'
355             } 1 .. $returns
356             }
357             }
358 12         67 });
359 12         29 Scalar::Util::weaken($self);
360 12 50       22 if ($returns > 1) {
361 0         0 $will_return{$ret} = $returns;
362             }
363             $ret
364 12         2556 }
365             }
366            
367             {package
368             List::Gen::Function;
369 2         7 use overload fallback => 1,
370             '.' => \&compose,
371             '~' => \&flip,
372 2         12 (map {$_ => \& curry} qw(< <<)),
373 1     1   11 (map {$_ => \&rcurry} qw(> >>));
  1         2  
  1         4  
374            
375             my $wrap = do {
376             sub {
377             my $src_fn = shift;
378             unless (ref $src_fn eq 'List::Gen::Bare::Function') {
379             push @_, $will_return->($src_fn);
380             goto &$fn;
381             }
382             my ($code, $proto) = @_;
383             $proto ||= '@';
384             bless Scalar::Util::set_prototype(\&$code, $proto), 'List::Gen::Bare::Function';
385             }
386             };
387            
388             sub compose {
389 0     0     my ($x, $y) = @_;
390 0 0         ($x, $y) = ($y, $x) if $_[2];
391            
392 0     0     $wrap->($x, sub {$x->(&$y)}, prototype $y)
  0            
393             }
394             sub curry {
395 0     0     my $x = shift;
396 0           my $y = \$_[0];
397 0           my $proto = prototype $x;
398 0 0         my $new_proto = $proto =~ /^\@(?!\@)/ ? $proto : $proto_tail->($proto);
399            
400 0     0     $wrap->($x, sub {$x->($$y, @_)}, $new_proto);
  0            
401             }
402             sub rcurry {
403 0     0     my $x = shift;
404 0           my $y = \$_[0];
405 0     0     $wrap->($x, sub {$x->(@_, $$y)}, $proto_init->(prototype $x));
  0            
406             }
407             sub flip {
408 0     0     my $x = shift;
409 0   0       my ($head, $tail) = (prototype($x) || '@') =~ /^([^;]+)(.*)/;
410 0           my $new_proto = (join '' => reverse $proto_split->($head)).$tail;
411            
412 0     0     $wrap->($x, sub {$x->(@_[reverse 0 .. $#_])}, $new_proto);
  0            
413             }
414             }
415            
416             {package
417             List::Gen::Bare::Function;
418             our @ISA = 'List::Gen::Function';
419             }
420            
421             {package
422             List::Gen::Thunk;
423             use overload fallback => 1,
424             '&{}' => sub {
425 0     0   0 $_[0] = ${$_[0]}->();
  0         0  
426 0 0       0 List::Gen::isagen($_[0]) ? $_[0]->_overloader : $_[0]
427             },
428 1     1   793 map {$_ => sub {$_[0] = ${$_[0]}->()}} qw( bool "" 0+ @{} %{} *{} );
  1     11   2  
  1         6  
  6         27  
  11         12  
  11         25  
429            
430 0     0     sub DESTROY {}
431             sub AUTOLOAD {
432 0     0     my $method = substr our $AUTOLOAD, 2 + length __PACKAGE__;
433 0 0 0       if (defined wantarray and not wantarray) {
434 0           my $args = \@_;
435             bless \sub {
436 0 0   0     $$args[0] = ${$$args[0]}->() if ref $$args[0] eq 'List::Gen::Thunk';
  0            
437 0 0         print "lazy call: $$args[0]\->$method(@$args[1..$#$args])\n"
438             if List::Gen::DEBUG;
439 0 0         my $code = $$args[0]->can($method) or Carp::croak("no method '$method'");
440 0           $code->(splice @$args);
441             }
442 0           } else {
443 0           $_[0] = ${$_[0]}->();
  0            
444 0 0         goto & {$_[0]->can($method) or Carp::croak("no method '$method'")}
  0            
445             }
446             }
447             }
448            
449             sub now {
450 0     0 0   for (@_) {
451 0           $_ = $$_->() while ref eq 'List::Gen::Thunk'
452             }
453 0 0         wantarray ? @_ : pop
454             }
455            
456            
457             =back
458            
459             =head1 AUTHOR
460            
461             Eric Strom, C<< >>
462            
463             =head1 BUGS
464            
465             report any bugs / feature requests to C, or through
466             the web interface at L.
467            
468             comments / feedback / patches are also welcome.
469            
470             =head1 COPYRIGHT & LICENSE
471            
472             copyright 2009-2011 Eric Strom.
473            
474             this program is free software; you can redistribute it and/or modify it under
475             the terms of either: the GNU General Public License as published by the Free
476             Software Foundation; or the Artistic License.
477            
478             see http://dev.perl.org/licenses/ for more information.
479            
480             =cut
481            
482            
483             'List::Gen::Lazy' if 'first require';