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';
|