FunctionalPerl
view release on metacpan or search on metacpan
t/examples-perlweekly-113-1.t
t/examples-perlweekly-113-2.t
t/examples-primes.t
t/examples-sendprepare
t/functional_XML-t-div.t
t/functional_XML-test.t
t/htmlgen.t
t/intro-basics.t
t/maintainer/perhaps
t/perl-goto-leak.t
t/perl-weaken-coderef-correctness.t
t/perl-weaken-coderef.t
t/perl/__SUB__-gc
t/perl/goto-leak
t/perl/weaken-coderef
t/perl/weaken-coderef-alternative
t/perl/weaken-coderef-alternative-FP
t/perl/weaken-coderef-alternative-__SUB__
t/perl/weaken-coderef-alternative-fix
t/perl/weaken-coderef-alternative-local
t/perl/weaken-coderef-simplified
t/pod_snippets.t
t/predicates.t
t/repl.t
t/require_and_run_tests.t
t/skip-internal.t
t/skip-leak.t
t/skip.t
t/testlazy.t
t/testlazy10.t
t/trampoline-fix.t
t/examples-perlweekly-113-2.t
t/examples-primes.t
t/examples-sendprepare
t/functional_XML-t-div.t
t/functional_XML-test.expected
t/functional_XML-test.t
t/htmlgen.t
t/intro-basics.t
t/maintainer/perhaps
t/perl-goto-leak.t
t/perl-weaken-coderef-correctness.t
t/perl-weaken-coderef.t
t/perl/__SUB__-gc
t/perl/goto-leak
t/perl/weaken-coderef
t/perl/weaken-coderef-alternative
t/perl/weaken-coderef-alternative-FP
t/perl/weaken-coderef-alternative-__SUB__
t/perl/weaken-coderef-alternative-fix
t/perl/weaken-coderef-alternative-local
t/perl/weaken-coderef-simplified
t/pod_snippets.t
t/predicates.t
t/repl.t
t/require_and_run_tests.t
t/skip-internal.t
t/skip-leak.t
t/skip.input
t/skip.t
t/testlazy.expected
t/testlazy.t
SHA256 0843a74401fb3bf90400014c22b888dfc46f718fb36554d26a20aa50fa809399 t/examples-perlweekly-113-2.t
SHA256 42e32427fb79978dcc7001c363b1a85a49b4c6b75e091124f272e3d63660fc11 t/examples-primes.t
SHA256 986f84e5f833abb9ac76f694b82275464e72d51aa17fa24de351ac032efa7a25 t/examples-sendprepare
SHA256 ea2587d00e33e9baac5f3a61b9edc0600df5d604b7731746244bd399e2b10168 t/functional_XML-t-div.t
SHA256 da7b53eb6ae8dee1732a79401ad5c95e8c96f730cd6b3bc12e7d87b92379ba12 t/functional_XML-test.expected
SHA256 ede145ea7e3afba587dc2367f1901d5b66b4d208f84a8cc0f06cb485e577d6a8 t/functional_XML-test.t
SHA256 25fbeb8432154745df98f02897783ab0512615babeb4bfd847c1c3eb6825d62a t/htmlgen.t
SHA256 91cf66ccf650addda359aa3d23649ed8b43b488ed18b36bccdf99dd7602f8f27 t/intro-basics.t
SHA256 825f5cf55cff1539c14d67b81bcc79e739d856fe524e2990c5c9d4cfc612ec17 t/maintainer/perhaps
SHA256 864b3cbd3e9ba7cfb65395b5352952c0e20b562a818f1db97dff2339408aa624 t/perl-goto-leak.t
SHA256 b65eb82e9595a99085d2b9ea78a61a38ec1e2d975a4e2a686f74f840452498df t/perl-weaken-coderef-correctness.t
SHA256 0b4e3416a22b8aac1dd3e9215046b7356eff8c0866b466752bb976843c15f7b9 t/perl-weaken-coderef.t
SHA256 c9548b075e1140e789819d2739c531af948eae64c3fd8f41cb9cbc5bb2a3ab4c t/perl/__SUB__-gc
SHA256 2b7e7e8f9e4b63f43c8b394348de94c9c16c463b6cf98c69ea98adf39adbb80e t/perl/goto-leak
SHA256 851d35a678e6154b17d2c84ec96f62944f55796a5c725b1bc98aeb5f85a8d320 t/perl/weaken-coderef
SHA256 6a4a68cb9be75d814729667cf4ed31093e5605a7c1202577e3a735f174416a7c t/perl/weaken-coderef-alternative
SHA256 f671dec99f4f3fb1f88e69be72b3a44cb0dd7e8429d9aa37490113c1d5517c30 t/perl/weaken-coderef-alternative-FP
SHA256 d9d0459b09ddb33d3bfef6f8c01ba492ab3e32a7acd1bab46f698cd47c044f6f t/perl/weaken-coderef-alternative-__SUB__
SHA256 932c1281f58de24cf04f1c7ca132a01713100cb1da8392c06a9571e7b5115dbd t/perl/weaken-coderef-alternative-fix
SHA256 7e1a87ea05847e9ca4630b4af5f1c9768ea1c45c1d029d79fc16664c116f0cee t/perl/weaken-coderef-alternative-local
SHA256 b6f0a9d9ba213003b10dae3bc0ccf443210dd93a9372a26194cb7f67c3b19931 t/perl/weaken-coderef-simplified
SHA256 eca6a1bda5ef1187a3f6285b01e2eba8b4fbce0ab0611857b69a4ad32103f199 t/pod_snippets.t
SHA256 b21857656b5bbe2213420a25f90788efa535341205034a182e597099cf39f346 t/predicates.t
SHA256 8c7702d4156224ed785f210b2a752b3df711fd7cee2daf5f6027a81b6b3273ef t/repl.t
SHA256 d47e2f998a90f0d9997ec9b2ac24434e64f6db6a7e3e7b4366b3a665d475b35c t/require_and_run_tests.t
SHA256 6f480af1b33cc831f9f15970d36405e060d56fdc316694ee534dd1756e7d4a21 t/skip-internal.t
SHA256 6677ec2ac7e11ebaa1ac00dedcbe174f911e401726b86db962d76d9606491848 t/skip-leak.t
SHA256 f4bb1975bf1f81f76ce824f7536c1e101a8060a632a52289d530a6f600d52c92 t/skip.input
SHA256 84bb43dff91e187fa8d67354f154a73d037cb1ba1ad3b9733a625019e8b1fb3f t/skip.t
SHA256 c258d4f0abc169d3e55a1358b7751b17d09cfe3588bd844ddd420ab973c405bd t/testlazy.expected
SHA256 59715a959c4e31765925becc9a767b7cc4f20eb7c78cae02ebbd6940da618b73 t/testlazy.t
docs/TODO.md view on Meta::CPAN
`FP::Repl::WithRepl` (maybe the same way calling code from `Carp`, or
perhaps `Trace::Mask`)?
* Would it be possible to write either an XS module that allows to
cancel an ongoing `die` from within a `$SIG{__DIE__}` handler, or
one that allows to set up another hook for die (in all relevant
cases like `die ..`, `1/0`, `use warnings FATAL => ..`).
* Idea: set slots to an object that reads like "value optimized away"
(perhaps an object of class `FP::_ValueOptimizedAway_`) instead of
to undef when letting go of values (OK, `weaken` uses undef of
course; but possibly weaken won't be necessary anymore once lexical
analysis exists and the interpreter can handle deletions at the call
site)
* Add a `boolean_eq` function?
* Show: handle cycles; pretty printing. Also, add an auto-forcing
dynamic parameter and print immediately instead of building a string
(have `show` just capture that)?
* Be consistent with exceptions, `array_drop [4], 3` should probably
docs/TODO.md view on Meta::CPAN
used for functions reused as methods. How should it be? `flip`
should work, for example, so do we have to live with methods
including $self in their argument count? (For this reason, much of
the code is now simply throwing the message "wrong number of
arguments" without any indication of the expected
count. `Function::Parameters` issues "Too many arguments" and "Not
enough arguments", `Method::Signatures` says "missing required
argument $a" or "was given too many arguments", both of which are
good.)
- should `rest` (`cdr`) weaken its argument in the case of streams?
(`first` clearly shouldn't, right?)
- add `FP::List`'s `none` and the `all` alias (also, remove `every`
*or* `all`?) to `FP::Stream`, or to common base class.
### Security, safety
- check 'XX.*[Ss]ecurity' comments
docs/blog/perl-weekly-challenges-113.md view on Meta::CPAN
full context open one of these links.
Trees and functional progamming are a good match if the trees don't
have circular links. In this case, the nodes can be immutable data
structures, for changes new node instances can be allocated which
share the unmodified children with the previous instance, thus only
little data needs to be copied, while still leaving the old version
of the tree around unmodifed, which is what functional
programming requires. Often trees in the imperative
world have links back to the parents, though, i.e. cycles, which
aren't a problem in Perl if weakening or destructors are used
correctly, but which violate the purely functional approach—how would
you re-use the child nodes if you create a new modified parent, but
the children are still pointing to the previous version of the parent? But
algorithms that need access to the parent nodes can instead maintain
linked lists to the parents while diving down the tree (separate from
the tree), thus parent links don't actually need to be stored in the
tree even if you think you need them. Anyway, this is a digression,
the given task is very simple, none of this parent business applies.
package PFLANZE::Node {
docs/blog/perl-weekly-challenges-113.md view on Meta::CPAN
This is the best way for a local function to get access to itself, so
that it can be self-recursive. Note that the following wouldn't work
as the sub is evaluated in the context before `$check` is introduced
and thus wouldn't have access to it:
my $check= sub ($chosen) { ... sub { .. $check .. } .. };
$check->(null)
This would work but leads to a cycle and thus memory leak (which
could be remedied by using an additional variable and then `weaken`ing
the self-referential variable, but `__SUB__` is going to be faster and
less to write):
my $check;
$check= sub ($chosen) { ... sub { .. $check .. } .. };
$check->(null)
Same problem with `my sub check ($chosen) { ... }`.
Also note that `__SUB__` *has* to be assigned to a lexical variable
docs/howto.md view on Meta::CPAN
### Reference cycles (and self-referential closures)
This is the classic issue with a system like Perl that uses reference
counting to determine when the last reference to a piece of data is
let go. Add a reference to the data structure to itself, and it will
never be freed. The leaked data structures are never reclaimed before
the exit of the process (or at least the perl interpreter) as they are
not reachable anymore (by normal programs). It's well-known in the
Perl community.
The solution is to strategically weaken a reference in the cycle
(usually the cyclic reference that's put inside the structure itself),
using `Scalar::Utils`'s `weaken`. `FP::Weak` also has `Weakened` which
is often handy, and `Keep` to protect a reference from such weakening
attacks in case it should remain strong.
The most frequent case involving reference cycles in functional
programs are self-referential closures:
sub foo {
my ($start) = @_;
my $x = calculate_x;
my $rec; $rec = sub {
my ($y) = @_;
docs/howto.md view on Meta::CPAN
$s->for_each (sub { print "> $_[0]\n" });
}
Without further ado, this will retain all lines of the file at `$path`
in `$s` while the `for_each` forces in (and itself releases) line
after line.
This is a problem that many programming language implementations (that
are not written to support lazy evaluation) have. Luckily in the case
of Perl, it can be worked around, by assigning `undef` or better
weakening the variable from within the called method:
sub for_each {
my ($s, $proc) = @_;
weaken $_[0];
...
}
`weaken` is a bit more friendly than `$_[0] = undef;` in that it
leaves the variable set if there's still another reference to the head
around.
With this trick (which is used in all of the relevant
functions/methods in `FP::Stream`), the above example actually *does*
release the head of the stream in a timely manner.
Now there may be situations where you actually really want to keep
`$s` alive. In such a case, you can protect its value from being
clobbered by passing it through the `Keep` function from `FP::Weak`:
docs/howto.md view on Meta::CPAN
swap if the program doesn't exit before).)
* being careful __not to let go of a deeply nested structure at
once__. By using `FP::Stream` instead of `FP::List` for bigger
lists and taking care that the head of the stream is not being
retained, there will never be any long list in memory at any given
time (it is being reclaimed piece after piece instead of all at
once)
Note that the same workaround as used with streams (weakening entries
in `@_`) will help with incremental deallocation with non-lazy lists
as well, and hence avoid the need for a big C stack, and avoid the
cumulation of time needed to deallocate the list (bad for soft
real-time latency). But weakening of non-lazy lists will/would be more
painful to handle for users, as it's more common to reuse them than
their lazy cousins, and thus functions in the functional-perl
libraries for non-lazy lists do not weaken their arguments. Arguably
it would really be best to make the language handle lifetimes
automatically (lexical variable analysis), it would benefit both the
lazy and non-lazy cases. (Side note: *some* streams, i.e. those with a
definition that uses earlier elements of themselves, have reference
cycles, and will need weakening of the head even with the lexical
analysis; but this should be a special case that should be fine to
handle accordingly.)
### See also
* A [post](https://news.ycombinator.com/item?id=8734719) about streams
in Scheme mentioning the memory retention issues that even some
Scheme implementations can have.
docs/howto.md view on Meta::CPAN
the tips above:
* Try to get the code working without lazyness first (don't use `lazy`
forms, use `FP::List` instead of `FP::Stream`). There's also
`FP::noLazy` that makes `lazy` a no-op in the current module. See
the documentation in this module.
* If you're getting `undef` in some place (like a subtree in a `PXML`
document missing (maybe triggering an undef warning in the
serializer)) and you don't know where it happens, and think it's
because of stream weakening, and just want to get the program
working first without worrying about memory retention, then disable
weakening using the offerings in `FP::Weak`.
## Tips and recommendations
* Both `Method::Signatures` and `Function::Parameters` offer
easy subroutine and method argument
declarations. `Function::Parameters` has the advantage that it's
lexically scoped, whereas `Method::Signatures` seems to be tied to
the namespace it was imported into. This means that in a file with
`{ package Foo; ... }` style sub-namespace parts, it's still enough
to import `Function::Parameters` just once at the top of the file,
docs/ideas.md view on Meta::CPAN
does Method::Signatures need to be modified to support this?
(Or should Function::Parameters be used instead?)
* reimplement parts in C (Pair, perhaps Promise?) to save some space
and CPU (but then, that prevents serialization [unless more work is
done]; also, to really optimize, want a custom/fake SV type that
includes the pair fields directly?)
* add set API, make `FP::HashSet` and OO based port.
* a variant of Scalar::Util's `weaken` that takes a value to be put
into the spot that held a reference when it is deleted, so that the
user can see something more useful like an object that carries a
message "weakened by stream_ref" (perhaps including caller location)
or some such instead of undef. (Even after changing the interpreter
to do lexical lifetime analysis, such values can be seen via
debugger infrastructure (stack locations). But then, instead of
weaken simple assignments can be used.)
* Byte code optimizer that automatically turns function calls in tail
position into gotos, if some 'TCO' pragma is in effect
* Provide a 'recursive let' form that includes weakening or
application of the fix point combinator, like:
my rec ($foo,$bar) =
sub { $bar->() },
sub { $foo->() };
* change `FP::Struct` into a Moose extension? Is Moose ok to have as a
hard dependency? (Because why are there all these Moose alternatives
like `Moo`?)
docs/intro.md view on Meta::CPAN
"atoms".
There's a catch, though, currently: unlike programming language
implementations that have been written explicitely to deal with the
functional programming style, the Perl implementation does not release
variables and subroutine arguments as early as theoretically possible,
which means that when calling subroutines that are consuming streams
(like `drop`) the head of the stream would not be released while
walking it, which would mean that the program could run out of
memory. The functional-perl libraries go to some pains to work around
the issue by weakening the subroutine argument slots (in `@_`). More
concretely, this means that after calling `drop` in the example above,
`$l` has been weakened, and if there's no other strong reference
holding the head of the stream, then it becomes undef. This means when
you try to run the same expression again, you get:
fperl> $l->drop(1000)->first
Exception: 'Can\'t call method "drop" on an undefined value at (eval 147) line 1.
'
fperl 1>
You can prevent this manually by protecting `$l` using the `Keep` function:
docs/intro.md view on Meta::CPAN
fix (fun ($self, $i) {
$i < $end ? null
: cons &$inverse($i), &$self($i-1)
})
->($start)->for_each(\&xprintln);
Another idea for a syntactical improvement implemented via a module
would be a recursive variant of `my`, i.e. one where the expression to
the right sees the variable directly, and then applies the `fix` or
weakening transparently, but, like the other ideas mentioned above,
this will take some effort and may only be feasible if there is enough
interest (and hence some form of at least moral support).
## More on functions
Pure functions (and methods) are good blocks for modular programming,
i.e. they are a good approach to make small reusable pieces that
combine easily: their simple API makes them easily
understandable. Their reliability (no side effects, hence no
examples/fibs view on Meta::CPAN
# called:
sub fibs {
my $fibs;
$fibs = cons bigint(1), cons bigint(1),
lazy { stream_zip_with \&add, $fibs, rest $fibs };
$fibs
}
# Note that while it creates a reference cycle, it won't leak, as the
# cycle is broken by stream_zip_with weakening its arguments, which we
# don't protect here (we do not use a Keep() wrapper).
# Here's a variant that relies on self-referencing the subroutine (a
# package variable) instead of mutating a lexical variable:
sub fibs2 {
cons bigint(1), cons bigint(1), lazy {
my $fibs = fibs2();
stream_zip_with \&add, $fibs, rest $fibs
}
examples/logwatch view on Meta::CPAN
if (my $pid = xfork) {
$pid
} else {
&$thunk();
exit 0;
}
}
# /lib
use Scalar::Util qw(weaken);
use Sys::Hostname qw(hostname);
use Chj::xopen;
use Chj::IO::Command;
use Chj::xpipe;
use Chj::singlequote;
use FP::Show;
#use FP::Repl::Trap; # or Chj::Backtrace
#use FP::Repl;
examples/logwatch view on Meta::CPAN
use Chj::xtmpfile;
sub xtmpfile_noautoclean () {
my $t = xtmpfile;
$t->autoclean(0);
$t
}
sub processlines_ ($lines, $out, $maybe_reporterpid) {
weaken $_[0];
my ($line, $rest) = $lines->first_and_rest;
warn "line='$line', maybe_reporterpid=" . singlequote($maybe_reporterpid)
if $verbose;
if ($line =~ /^$REPORTMSG/) {
warn "REPORT!" if $verbose;
# XX is it really guaranteed that lines are never broken
# apart?
$out->xclose;
$$config{report}->($out->path);
examples/logwatch view on Meta::CPAN
warn "sent $REPORTMSG" if $verbose;
}
);
} else {
tail processlines_($rest, $out, $maybe_reporterpid)
}
}
}
sub processlines($lines) {
weaken $_[0];
processlines_($lines, xtmpfile_noautoclean, undef)
}
my $tailpid = forked {
$r->xclose;
$w->xdup2(1);
xexec @tailcmd, "--", $$config{logfile};
};
my $lines = fh_to_linestream(
examples/pdf-to-html view on Meta::CPAN
sub _svgpaths_to_html_actions ($svgpaths, $title, $outdir) {
# (No need to protect $svgpaths with `Keep` here since it's a
# purearray because of the sorting)
# the html fragment for one page from the pdf
my $page_htmlfragment = sub ($is_last, $for_svgpath) {
# sub needed to work around destruction of document by
# weakening done in serializer (ugly, really replace all
# weakening and Keep stuff with a fixed perl?)
my $TR_TD_nav = sub {
TR TD { align => "center" },
navigation_html($svgpaths, $for_svgpath, $opt_single)
};
[
&$TR_TD_nav,
TR(TD(IMG { src => basename($for_svgpath), width => "100%" })),
$opt_single ? ($is_last ? (TR TD HR) : ()) : &$TR_TD_nav
]
};
examples/skip view on Meta::CPAN
# `chunks_change_tail` returns a stream of the unmodified chunks until
# passing through one more would make the sum of the remaining chunks
# till the end of the stream smaller than $minsize; pass the remainder
# to &$fn($tail, $remainingsize) and use its result as the tail of the
# output stream. (See test cases below for illustration.)
sub chunks_change_tail {
@_ == 3 or fp_croak_arity 3;
my ($chunks, $minsize, $fn) = @_;
weaken $_[0];
is_null $chunks and die "got empty input";
# start and rest are parts of the same stream of chunks,
# windowsize is the number of bytes between them
my $next;
$next = sub {
@_ == 3 or fp_croak_arity 3;
my ($start, $rest, $windowsize) = @_;
my $next = $next;
intro/more_tailcalls view on Meta::CPAN
TEST {
time_this { trampoline tramp2_even 60000 } "TC"
}
1;
# ------------------------------------------------------------------
# Also note: all of the above example are defining functions as
# package globals, which makes it trivial to call themselves
# recursively. If you need to define them as lexicals, then you need
# to heed the advice given in [[README]] with regards to self
# calls (recursive function definitions), either by way of weaken:
use Scalar::Util 'weaken';
use FP::Stream 'Weakened'; # XX should probably move to non-lazyness
# related place
func weakened_even($n) {
my ($odd, $even);
$odd = func($n) {
if ($n == 0) {
0
} else {
tail &$even($n - 1)
}
};
$even = func($n) {
if ($n == 0) {
intro/more_tailcalls view on Meta::CPAN
};
# do *not* make this a tail call or $even will become undef on
# bleadperl at some point (not so on v5.14.2):
# (XXX Perl issue, or what are the rules here?)
Weakened($even)->($n)
}
TEST {
($^V->{version}[1] > 20)
? weakened_even 60000
: warn "skipping test on older perl"
}
1;
# XXX this actually fails both on v5.14.2 and bleadperl for undefined
# subroutine call. Submit bug report?
# or by using the n-ary fixpoint combinator:
use FP::fix;
lib/FP/Abstract/Sequence.pm view on Meta::CPAN
# *set = blessing \&array_set;
# *push = blessing \&array_push;
# *pop = blessing_snd \&array_pop;
# *shift = blessing_snd \&array_shift;
# *unshift = blessing \&array_unshift;
#XXX other
# group group_by
# zip2
# XXX these don't weaken the caller arguments, thus will leak for
# streams. How to solve this (and not copy-paste-adapt the methods
# manually) without fixing perl?
sub flatten {
@_ == 1 or @_ == 2 or fp_croak_arity "1 or 2";
my ($self, $perhaps_tail) = @_;
$self->fold_right(
sub {
my ($v, $rest) = @_;
$v->append($rest)
lib/FP/Abstract/Sequence.pm view on Meta::CPAN
sub none {
@_ == 2 or fp_croak_arity 2;
my ($s, $pred) = @_;
$s->every(complement $pred)
}
sub split_at {
@_ == 2 or fp_croak_arity 2;
my ($s, $pos) = @_;
# XXX weaken as all of them.
($s->take($pos), $s->drop($pos))
}
sub chunks_of {
@_ == 2 or fp_croak_arity 2;
my ($s, $chunklen) = @_;
# XXX weaken as all of them.
$s->stream->chunks_of($chunklen)
}
sub strictly_chunks_of {
@_ == 2 or fp_croak_arity 2;
my ($s, $chunklen) = @_;
# XXX weaken as all of them.
$s->stream->strictly_chunks_of($chunklen)
}
# join in Haskell is doing "++" on the items, should probably choose a
# protocol for this as well; for now, hard-code to strings_join:
sub join {
my ($s) = @_;
# Tail-call, please, for 'weakening maintenance'.
# XX only AUTOLOAD is defined, not `can`! But $s was already
# forced by the AUTOLOAD thus nothing more is needed here. But
# this might change!
my $m = $s->can("strings_join")
# bug since it's requested by the interface
or die "bug: missing strings_join method on: $s";
goto $m
lib/FP/IOStream.pm view on Meta::CPAN
timestream
xstream_print
xstream_to_file
xfile_replace_lines
);
our %EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);
use FP::Lazy;
use Chj::xopendir qw(perhaps_opendir);
use FP::List ':all';
use FP::Stream qw(stream_map weaken Weakened);
use FP::PureArray qw(array_to_purearray);
use FP::Array_sort;
use FP::Ops 'the_method';
use Carp;
use Chj::singlequote ":all";
use Chj::xopen qw(
xopen_read
xopen_write
xopen_append
xopen_update
lib/FP/IOStream.pm view on Meta::CPAN
}
"FP::List::Pair"
};
Weakened($lp)->();
}
sub xstream_print {
@_ == 1 or @_ == 2 or fp_croak_arity "1 or 2";
my ($s, $maybe_fh) = @_;
my $fh = $maybe_fh // glob_to_fh(*STDOUT);
weaken $_[0];
$s->for_each(
sub {
print $fh $_[0] or croak "xstream_print: writing to $fh: $!";
}
);
}
sub xstream_to_file {
@_ == 2 or @_ == 3 or fp_croak_arity "2 or 3";
my ($s, $path, $maybe_mode) = @_;
my $out = xtmpfile $path;
weaken $_[0];
xstream_print($s, $out);
$out->xclose;
$out->xputback($maybe_mode);
}
# read and write back a file, passing its lines as a stream to the
# given function; written to temp file that's renamed into place upon
# successful completion.
sub xfile_replace_lines {
@_ == 2 or fp_croak_arity 2;
lib/FP/List.pm view on Meta::CPAN
use FP::Lazy;
use FP::Lazy qw(force_noeval);
use Chj::xperlfunc qw(xprint xprintln);
use FP::Combinators qw(flip flip2of3 rot3right rot3left);
use FP::Optional qw(perhaps_to_maybe);
use Chj::TEST;
use FP::Predicates qw(is_natural0 either is_natural complement is_even is_zero);
use FP::Div qw(inc dec);
use FP::Show;
use Scalar::Util qw(weaken blessed);
use FP::Weak qw(Weakened);
use FP::Interfaces;
use Carp;
use FP::Carp;
use FP::Docstring;
our $immutable = 1; # whether pairs are to be made immutable
#use FP::Array 'array_fold_right'; can't, recursive dependency XX (see copy below)
#(Chj::xIOUtil triggers it)
lib/FP/List.pm view on Meta::CPAN
TEST_EXCEPTION { [list(8, 9)->xone] } "expected 1 value, got more";
TEST_EXCEPTION { [list()->xone] } "expected 1 value, got none";
sub make_ref {
my ($is_stream) = @_;
my $liststream = $is_stream ? "stream" : "list";
sub {
@_ == 2 or fp_croak_arity 2;
my ($s, $i) = @_;
weaken $_[0] if $is_stream;
is_natural0 $i or fp_croak "invalid index: " . show($i);
my $orig_i = $i;
LP: {
$s = force $s;
if (is_pair $s) {
if ($i <= 0) {
$s->car
} else {
$s = $s->cdr;
$i--;
lib/FP/List.pm view on Meta::CPAN
# And the result of this function will open up (interrupt the cycle)
# as soon as you let go of the front element.
sub weaklycircularlist {
my $l = list(@_);
my $last = $l->drop($#_);
if ($immutable) {
Internals::SvREADONLY $$last[1], 0;
$$last[1] = $l;
weaken($$last[1]);
Internals::SvREADONLY $$last[1], 1;
} else {
$$last[1] = $l;
weaken($$last[1]);
}
$l
}
use Chj::Destructor;
TEST {
my $z = 0;
my $v = do {
my $l = circularlist "a", "b", Destructor { $z++ }, "d";
lib/FP/List.pm view on Meta::CPAN
TEST { nonempty_list_of(\&is_natural)->(1) } undef; # XX vs. above
TEST { nonempty_list_of(\&is_natural)->(list()) } ''; # vs. 0 ?
sub make_length {
my ($is_stream) = @_;
my $liststream = $is_stream ? "stream" : "list";
sub {
@_ == 1 or fp_croak_arity 1;
my ($l) = @_;
weaken $_[0] if $is_stream;
my $len = 0;
$l = force $l;
while (!is_null $l) {
if (is_pair $l) {
$len++;
$l = force $l->cdr;
} elsif (defined blessed($l)
and my $m = $l->can("FP_Sequence_length"))
{
@_ = ($l, $len);
lib/FP/List.pm view on Meta::CPAN
[5, 4, 3];
sub make_for_each {
@_ == 2 or fp_croak_arity 2;
my ($is_stream, $with_islast) = @_;
my $liststream = $is_stream ? "stream" : "list";
sub {
@_ == 2 or fp_croak_arity 2;
my ($proc, $s) = @_;
weaken $_[1] if $is_stream;
LP: {
$s = force $s;
if (is_pair $s) {
my $s2 = cdr $s;
&$proc(scalar car($s), $with_islast ? scalar is_null($s2) : ());
$s = $s2;
redo LP;
} elsif (is_null $s) {
# drop out
lib/FP/List.pm view on Meta::CPAN
TEST_STDOUT { list(a => 10, b => 20)->alist->write_sexpr }
'(("a" . "10") ("b" . "20"))';
sub make_filter {
my ($is_stream) = @_;
my $filter;
$filter = sub {
@_ == 2 or fp_croak_arity 2;
my ($fn, $l) = @_;
weaken $_[1] if $is_stream;
lazy_if {
no warnings 'recursion'; # XXX this should be tail calling???
$l = force $l;
is_null($l) ? $l : do {
my ($a, $r) = $l->first_and_rest;
no warnings 'recursion';
my $r2 = &$filter($fn, $r);
&$fn($a) ? cons($a, $r2) : $r2
}
}
lib/FP/List.pm view on Meta::CPAN
*FP::List::List::filter = flip \&list_filter;
# almost-COPY of filter
sub make_filter_with_tail {
my ($is_stream) = @_;
my $filter_with_tail;
$filter_with_tail = sub {
@_ == 3 or fp_croak_arity 3;
my ($fn, $l, $tail) = @_;
weaken $_[1] if $is_stream;
lazy_if {
$l = force $l;
is_null($l) ? $tail : do {
my $a = car $l;
my $r = &$filter_with_tail($fn, cdr($l), $tail);
&$fn($a) ? cons($a, $r) : $r
}
}
$is_stream;
};
lib/FP/List.pm view on Meta::CPAN
TEST { [list(3, 1, 37, -5)->find_tail(\&is_even)] }
[undef];
# Grouping
sub make_group {
my ($is_stream) = @_;
sub {
@_ >= 2 and @_ <= 3 or fp_croak_arity "2-3";
my ($equal, $s, $maybe_tail) = @_;
weaken $_[1] if $is_stream;
lazy_if {
FORCE $s;
if (is_null $s) {
$maybe_tail // null
} else {
my ($a, $r) = $s->first_and_rest;
my $rec;
$rec = sub {
my ($prev, $s) = @_;
lazy_if {
lib/FP/List.pm view on Meta::CPAN
sub make_split {
my ($is_stream) = @_;
sub {
__
'split($self, $pred, $retain_item, $maybe_tail): split on items for which $pred returns true. If $retain_item is true, the item that matched will be included in the previous group.';
@_ >= 2 and @_ <= 4 or fp_croak_arity "2-4";
require FP::PureArray;
my ($s, $pred, $retain_item, $maybe_tail) = @_;
weaken $_[1] if $is_stream;
lazy_if {
FORCE $s;
if (is_null $s) {
$maybe_tail // null
} else {
my $rec;
$rec = sub {
my ($s) = @_;
lazy_if {
my $s = $s;
lib/FP/Stream.pm view on Meta::CPAN
stream_to_list
stream_sort
stream_group
stream_mixed_flatten
stream_mixed_fold_right
stream_mixed_state_fold_right
stream_any
stream_show
);
our @EXPORT_OK = qw(
F weaken
cons car cdr first rest
stream_cartesian_product
stream_cartesian_product_2
);
our %EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);
use FP::Lazy;
use FP::List ":all";
use FP::Combinators qw(flip flip2of3 rot3right rot3left);
use Chj::TEST;
lib/FP/Stream.pm view on Meta::CPAN
# The author of this library decided to stay with the Scheme
# tradition: it seems to make sense to keep the argument order the
# same (as determined by the type of the arguments) for both kinds of
# fold. If nothing more this allows `*cons` to be passed as $fn
# directly to construct a list.
sub stream_fold {
@_ == 3 or fp_croak_arity 3;
my ($fn, $start, $l) = @_;
weaken $_[2];
my $v;
LP: {
$l = force $l;
if (is_pair $l) {
($v, $l) = first_and_rest $l;
$start = &$fn($v, $start);
redo LP;
}
}
$start
lib/FP/Stream.pm view on Meta::CPAN
stream_fold sub { [@_] }, 0, stream(1, 2)
}
[2, [1, 0]];
TEST { stream_fold(\&cons, null, stream(1, 2))->array }
[2, 1];
sub stream_sum {
@_ == 1 or fp_croak_arity 1;
my ($s) = @_;
weaken $_[0];
stream_fold(sub { $_[0] + $_[1] }, 0, $s)
}
# XXX sum is in FP::Abstract::Sequence now, although not weakening.. soo ?
*FP::List::List::stream_sum = \&stream_sum;
TEST {
stream_iota->map(sub { $_[0] * $_[0] })->take(5)->sum
}
30;
# leak test: XXX make this into a LEAK_TEST or so form(s), and env var, ok?
#TEST{ stream_iota->rest->take(100000)->sum }
# 5000050000;
sub stream_append2 {
@_ == 2 or fp_croak_arity 2;
my ($l1, $l2) = @_;
weaken $_[0];
weaken $_[1];
lazyT {
$l1 = force $l1;
is_null($l1) ? $l2 : cons(car($l1), stream_append(cdr($l1), $l2))
}
"FP::List::List"
}
sub stream_append {
if (@_ == 0) {
null
} elsif (@_ == 1) {
$_[0]
} elsif (@_ == 2) {
goto \&stream_append2
} else {
my $ss = list(reverse @_);
weaken $_ for @_;
# ^ WHEN is this even needed, I think it is when calling a
# stream consumer afterwards, right?
$ss->rest->fold(
sub {
my ($s, $rest) = @_;
lazyT {
stream_append2($s, $rest)
}
"FP::List::List"
lib/FP/Stream.pm view on Meta::CPAN
["take 2", "a"],
["take 3", "a", "b"],
["take 4", "a", "b"],
["take 5", "a", "b", "c"],
["take 6", "a", "b", "c"]
];
sub stream_map {
@_ == 2 or fp_croak_arity 2;
my ($fn, $l) = @_;
weaken $_[1];
lazyT {
$l = force $l;
is_null($l) ? null : cons(&$fn(car $l), stream_map($fn, cdr $l))
}
"FP::List::List"
}
*FP::List::List::stream_map = flip \&stream_map;
sub stream_map_with_tail {
@_ == 3 or fp_croak_arity 3;
my ($fn, $l, $tail) = @_;
weaken $_[1];
lazyT {
$l = force $l;
is_null($l)
? $tail
: cons(&$fn(car $l), stream_map_with_tail($fn, cdr($l), $tail))
}
"FP::Abstract::Sequence"
}
*FP::List::List::stream_map_with_tail = flip2of3 \&stream_map_with_tail;
# 2-ary (possibly slightly faster) version of stream_zip
sub stream_zip2 {
@_ == 2 or fp_croak_arity 2;
my ($l, $m) = @_;
do { weaken $_ if is_promise $_ }
for @_; #needed?
lazyT {
$l = force $l;
$m = force $m;
(is_null $l or is_null $m)
? null
: cons([car($l), car($m)], stream_zip2(cdr($l), cdr($m)))
}
"FP::List::List"
}
*FP::List::List::stream_zip2 = \&stream_zip2;
# n-ary version of stream_zip2
sub stream_zip {
my @ps = @_;
do { weaken $_ if is_promise $_ }
for @_; #needed?
lazyT {
my @vs = map {
my $v = force $_;
is_null($v) ? return null : $v
} @ps;
my $a = [map { car $_ } @vs];
my $b = stream_zip(map { cdr $_ } @vs);
cons($a, $b)
}
"FP::List::List"
}
*FP::List::List::stream_zip = \&stream_zip; # XX fall back on zip2
# for 2 arguments?
sub stream_zip_with {
my ($f, $l1, $l2) = @_;
weaken $_[1];
weaken $_[2];
lazyT {
my $l1 = force $l1;
my $l2 = force $l2;
(is_null $l1 or is_null $l2) ? null : cons &$f(car($l1), car($l2)),
stream_zip_with($f, cdr($l1), cdr($l2))
}
"FP::List::List"
}
*FP::List::List::stream_zip_with = flip2of3 \&stream_zip_with;
lib/FP/Stream.pm view on Meta::CPAN
*FP::List::List::stream_filter_with_tail = flip2of3 \&stream_filter_with_tail;
# http://hackage.haskell.org/package/base-4.7.0.2/docs/Prelude.html#v:foldr1
# foldr1 is a variant of foldr that has no starting value argument,
# and thus must be applied to non-empty lists.
sub stream_foldr1 {
@_ == 2 or fp_croak_arity 2;
my ($fn, $l) = @_;
weaken $_[1];
lazy {
$l = force $l;
if (is_pair $l) {
&$fn(car($l), stream_foldr1($fn, cdr($l)))
} elsif (is_null $l) {
die "foldr1: reached end of list"
} else {
die "improper list: $l"
}
}
}
*FP::List::List::stream_foldr1 = flip \&stream_foldr1;
sub stream_fold_right {
@_ == 3 or fp_croak_arity 3;
my ($fn, $start, $l) = @_;
weaken $_[2];
lazy {
$l = force $l;
if (is_pair $l) {
&$fn(car($l), stream_fold_right($fn, $start, cdr $l))
} elsif (is_null $l) {
$start
} else {
die "improper list: $l"
}
}
lib/FP/Stream.pm view on Meta::CPAN
sub string_to_stream {
@_ >= 1 and @_ <= 2 or fp_croak_arity "1-2";
my ($str, $maybe_tail) = @_;
stream__string_fold_right(\&cons, $maybe_tail // null, $str)
}
sub stream_to_string {
@_ == 1 or fp_croak_arity 1;
my ($l) = @_;
weaken $_[0];
my $str = "";
while (($l = force $l), !is_null $l) {
$str .= car $l;
$l = cdr $l;
}
$str
}
*FP::List::List::stream_string = \&stream_to_string;
TEST { stream("Ha", "ll", "o")->string } "Hallo";
sub stream_strings_join {
@_ == 2 or fp_croak_arity 2;
my ($l, $val) = @_;
weaken $_[0];
# XX can't I just use list_strings_join? no, the other way round
# would work.
# depend on FP::Array. Lazily, for depencency cycle?
require FP::Array;
FP::Array::array_strings_join(stream_to_array($l), $val);
}
*FP::List::List::stream_strings_join = \&stream_strings_join;
lib/FP/Stream.pm view on Meta::CPAN
sub stream_for_each;
*stream_for_each = FP::List::make_for_each(1, 0);
sub stream_for_each_with_islast;
*stream_for_each_with_islast = FP::List::make_for_each(1, 1);
*FP::List::List::stream_for_each = flip \&stream_for_each;
sub stream_drop {
@_ == 2 or fp_croak_arity 2;
my ($s, $n) = @_;
weaken $_[0];
while ($n > 0) {
$s = force $s;
die "stream too short" if is_null $s;
$s = cdr $s;
$n--
}
$s
}
*FP::List::List::stream_drop = \&stream_drop;
sub stream_take {
@_ == 2 or fp_croak_arity 2;
my ($s, $n) = @_;
weaken $_[0];
lazyT {
if ($n > 0) {
$s = force $s;
is_null($s) ? $s : cons(car($s), stream_take(cdr($s), $n - 1));
} else {
null
}
}
"FP::List::List"
}
*FP::List::List::stream_take = \&stream_take;
sub stream_take_while {
@_ == 2 or fp_croak_arity 2;
my ($fn, $s) = @_;
weaken $_[1];
lazyT {
$s = force $s;
if (is_null $s) {
null
} else {
my $a = car $s;
if (&$fn($a)) {
cons $a, stream_take_while($fn, cdr $s)
} else {
null
lib/FP/Stream.pm view on Meta::CPAN
}
}
"FP::List::List"
}
*FP::List::List::stream_take_while = flip \&stream_take_while;
sub stream_slice {
@_ == 2 or fp_croak_arity 2;
my ($start, $end) = @_;
weaken $_[0];
weaken $_[1];
$end = force $end;
my $rec;
$rec = sub {
my ($s) = @_;
weaken $_[0];
my $rec = $rec;
lazyT {
$s = force $s;
if (is_null $s) {
$s # null
} else {
if ($s eq $end) {
null
} else {
cons car($s), &$rec(cdr $s)
lib/FP/Stream.pm view on Meta::CPAN
goto &{ Weakened $rec};
}
*FP::List::List::stream_slice = \&stream_slice;
# maybe call it `cut_at` instead?
sub stream_drop_while {
@_ == 2 or fp_croak_arity 2;
my ($pred, $s) = @_;
weaken $_[1];
lazyT {
LP: {
$s = force $s;
if (!is_null $s and &$pred(car $s)) {
$s = cdr $s;
redo LP;
} else {
$s
}
}
lib/FP/Stream.pm view on Meta::CPAN
}, "stream";
TEST { list_ref cons(0, stream(1, 2, 3)), 2 } 2;
TEST { stream_ref cons(0, stream(1, 2, 3)), 2 } 2;
# force everything deeply
sub F {
@_ == 1 or fp_croak_arity 1;
my ($v) = @_;
#weaken $_[0]; since I usually use it interactively, and should
# only be good for short sequences, better don't
if (is_promise $v) {
F(force $v);
} else {
if (length(my $r = ref $v)) {
if (is_pair $v) {
cons(F(car $v), F(cdr $v))
} elsif (is_null $v) {
$v
} elsif ($r eq "ARRAY") {
lib/FP/Stream.pm view on Meta::CPAN
}
} else {
$v
}
}
}
sub stream_to_array {
@_ == 1 or fp_croak_arity 1;
my ($l) = @_;
weaken $_[0];
my $res = [];
my $i = 0;
$l = force $l;
while (!is_null $l) {
my $v = car $l;
$$res[$i] = $v;
$l = force cdr $l;
$i++;
}
$res
}
*FP::List::List::stream_array = \&stream_to_array;
sub stream_to_purearray {
my ($l) = @_;
weaken $_[0];
my $a = stream_to_array $l;
require FP::PureArray;
FP::PureArray::array_to_purearray($a)
}
*FP::List::List::stream_purearray = \&stream_to_purearray;
TEST {
stream(1, 3, 4)->purearray->map (sub { $_[0]**2 })
}
bless [1, 9, 16], "FP::_::PureArray";
sub stream_to_list {
@_ == 1 or fp_croak_arity 1;
my ($l) = @_;
weaken $_[0];
array_to_list stream_to_array $l
}
*FP::List::List::stream_list = \&stream_to_list;
sub stream_sort {
@_ == 1 or @_ == 2 or fp_croak_arity "1 or 2";
my ($l, $maybe_cmp) = @_;
stream_to_purearray($l)->sort ($maybe_cmp)
}
lib/FP/Stream.pm view on Meta::CPAN
# add a lazy merge sort instead/in addition?
sub stream_group;
*stream_group = FP::List::make_group(1);
sub FP::List::List::stream_group {
__
'group($self, $equal, $maybe_tail): build groups of subsequent items that are $equal.';
@_ >= 2 and @_ <= 3 or fp_croak_arity "2-3";
my ($self, $equal, $maybe_tail) = @_;
weaken $_[0];
stream_group($equal, $self, $maybe_tail)
}
sub stream_split;
*stream_split = FP::List::make_split(1);
sub stream_mixed_flatten {
@_ >= 1 and @_ <= 3 or fp_croak_arity "1-3";
my ($v, $maybe_tail, $maybe_delay) = @_;
#XXX needed, no? weaken $_[0] if ref $_[0];
mixed_flatten($v, $maybe_tail // null, $maybe_delay || \&lazyLight)
}
*FP::List::List::stream_mixed_flatten = \&stream_mixed_flatten;
sub stream_any {
@_ == 2 or @_ == 3 or fp_croak_arity "2 or 3";
my ($pred, $l, $prev_false) = @_;
weaken $_[1];
$l = force $l;
if (is_pair $l) {
my $v = $pred->(car $l);
$v or do {
my $r = cdr $l;
stream_any($pred, $r, $v)
}
} elsif (is_null $l) {
$prev_false
} else {
lib/FP/Stream.pm view on Meta::CPAN
)->(10)->take(3)->array
}
[[0, 10], [1, 11], [2, 12]];
# are these warranted?: (or should they be deprecated right upon
# introduction?)
sub stream_mixed_fold_right {
@_ == 3 or fp_croak_arity 3;
my ($fn, $state, $v) = @_;
weaken $_[2] if ref $_[2];
@_ = ($fn, $state, stream_mixed_flatten $v);
goto \&stream_fold_right
}
*FP::List::List::stream_mixed_fold_right = rot3left \&stream_mixed_fold_right;
sub stream_mixed_state_fold_right {
@_ == 3 or fp_croak_arity 3;
my ($fn, $statefn, $v) = @_;
weaken $_[2] if ref $_[2];
@_ = ($fn, $statefn, stream_mixed_flatten $v);
goto \&stream_state_fold_right
}
*FP::List::List::stream_mixed_state_fold_right
= rot3left \&stream_mixed_state_fold_right;
# 'cross product'
sub stream_cartesian_product_2 {
@_ == 2 or fp_croak_arity 2;
my ($a, $orig_b) = @_;
weaken $_[0];
weaken $_[1];
my $rec;
$rec = sub {
my ($a, $b) = @_;
my $rec = $rec;
lazyT {
if (is_null $a) {
null
} elsif (is_null $b) {
&$rec(cdr($a), $orig_b);
} else {
lib/FP/Stream.pm view on Meta::CPAN
list("E", "D", "A"),
list("E", "D", "B"),
list("F", "C", "A"),
list("F", "C", "B"),
list("F", "D", "A"),
list("F", "D", "B")
);
sub stream_cartesian_product {
my @v = @_;
weaken $_ for @_;
if (!@v) {
die "stream_cartesian_product: need at least 1 argument"
} elsif (@v == 1) {
stream_map \&list, $v[0]
} else {
my $first = shift @v;
stream_cartesian_product_2($first, stream_cartesian_product(@v))
}
}
lib/FP/Stream.pm view on Meta::CPAN
# chunksOf from Haskell's Data.List.Split, but returns `purearray`s
# instead of lists.
sub make_chunks_of {
my ($strictly, $lazy) = @_;
sub {
@_ == 2 or fp_croak_arity 2;
my ($s, $chunklen) = @_;
$chunklen >= 1 or croak "invalid chunklen: $chunklen";
weaken $_[0] if $lazy; # although tie down is only chunk sized
require FP::PureArray;
fix(
sub {
my ($rec, $s) = @_;
weaken $_[0] if $lazy; # although tie down is only chunk sized
lazy_if {
return null if $s->is_null;
my @v;
for my $i (1 .. $chunklen) {
if ($s->is_null) {
die "premature end of input" if $strictly;
} else {
push @v, $s->first;
$s = $s->rest;
}
lib/FP/Text/CSV.pm view on Meta::CPAN
csv_fh_to_rows
csv_file_to_rows
csv_printer
rows_to_csv_fh
rows_to_csv_file
);
our %EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);
use FP::List ":all";
use FP::Lazy ":all";
use FP::Stream 'Weakened', 'weaken';
use Text::CSV;
use FP::HashSet 'hashset_union';
use Chj::xopen 'xopen_read';
use FP::Carp;
use FP::Stream "stream_for_each";
use Chj::xtmpfile;
use FP::Docstring;
our $defaults = +{ binary => 1, sep_char => ",", eol => "\r\n", };
lib/FP/Text/CSV.pm view on Meta::CPAN
or die "could not write CSV row: " . $csv->error_diag;
# XX ok?
}
}
sub rows_to_csv_fh {
__ 'rows_to_csv_fh($s, $fh, $maybe_params) -> ()';
@_ == 2 or @_ == 3 or fp_croak_arity "2-3";
my ($s, $fh, $maybe_params) = @_;
weaken $_[0];
stream_for_each csv_printer($fh, $maybe_params), $s
}
sub rows_to_csv_file {
__ 'rows_to_csv_file($s, $path, $maybe_params) -> ()';
@_ == 2 or @_ == 3 or fp_croak_arity "2-3";
my ($s, $path, $maybe_params) = @_;
weaken $_[0];
my $out = xtmpfile $path;
binmode($out, ":encoding(utf-8)") or die "binmode";
rows_to_csv_fh($s, $out, $maybe_params);
$out->xclose;
$out->xputback(0666 & ~umask);
}
1
lib/FP/Weak.pm view on Meta::CPAN
# Copyright (c) 2015-2020 Christian Jaeger, copying@christianjaeger.ch
#
# This is free software, offered under either the same terms as perl 5
# or the terms of the Artistic License version 2 or the terms of the
# MIT License (Expat version). See the file COPYING.md that came
# bundled with this file.
#
=head1 NAME
FP::Weak - utilities to weaken references
=head1 SYNOPSIS
use FP::Weak;
sub foo {
my $f; $f = sub { my ($n,$tot) = @_; $n < 100 ? &$f($n+1, $tot+$n) : $tot };
Weakened $f
}
is foo->(10, 0), 4905;
# the subroutine returned from foo will not be leaked.
=head1 DESCRIPTION
=over 4
=item weaken <location>
`Scalar::Util`'s `weaken`, unless one of the `with_..` development
utils are used (or `$FP::Weak::weaken` is changed).
=item Weakened <location>
Calls `weaken <location>` after copying the reference, then returns
the unweakened reference.
=item Keep <location>
Protect <location> from being weakened by accessing elements of `@_`.
=back
Optionally exported development utils:
=over 4
=item noweaken ($var), noWeakened ($var)
No-ops. The idea is to prefix the weakening ops with 'no' to disable
them.
=item warnweaken ($var), warnWeakened ($var)
Give a warning in addition to the weakening operation.
=item cluckweaken ($var), cluckWeakened ($var)
Give a warning with backtrace in addition to the weakening operation.
=item with_noweaken { code }, &with_noweaken ($proc)
=item with_warnweaken { code } (and same as above)
=item with_cluckweaken { code }
Within their dynamic scope, globally change `weaken` to one of the
alternatives
=item do_weaken (1|0|"yes"|"no"|"on"|"off"|"warn"|"cluck")
Turn weakening on and off (unscoped, 'persistently').
=back
=head1 NOTE
This is alpha software! Read the status section in the package README
or on the L<website|http://functional-perl.org/>.
=cut
package FP::Weak;
use strict;
use warnings;
use warnings FATAL => 'uninitialized';
use Exporter "import";
our @EXPORT = qw(weaken Weakened Keep);
our @EXPORT_OK = qw(
do_weaken
noweaken noWeakened with_noweaken
warnweaken warnWeakened with_warnweaken
cluckweaken cluckWeakened with_cluckweaken
);
our %EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);
use Scalar::Util ();
use FP::Carp;
our $weaken = \&Scalar::Util::weaken;
sub weaken {
@_ == 1 or fp_croak_arity 1;
goto &$weaken
}
# XX is there really no way (short of re-exporting everywhere with a
# Chj::ruse approach) to avoid the extra function call cost?
# protect a variable from being pruned by callees that prune their
# arguments
sub Keep {
@_ == 1 or fp_croak_arity 1;
my ($v) = @_;
$v
}
# weaken a variable, but also provide a non-weakened reference to its
# value as result
sub Weakened {
@_ == 1 or fp_croak_arity 1;
my ($ref) = @_;
weaken $_[0];
$ref
}
sub noweaken {
@_ == 1 or fp_croak_arity 1;
# noop
}
sub noWeakened {
@_ == 1 or fp_croak_arity 1;
$_[0]
}
sub with_noweaken (&) { local $weaken = \&noweaken; &{ $_[0] }() }
use Carp;
sub warnweaken {
@_ == 1 or fp_croak_arity 1;
carp "weaken ($_[0])";
Scalar::Util::weaken($_[0]);
}
sub warnWeakened {
@_ == 1 or fp_croak_arity 1;
carp "weaken ($_[0])";
Weakened($_[0]);
}
sub with_warnweaken (&) { local $weaken = \&warnweaken; &{ $_[0] }() }
use Carp 'cluck';
use FP::Carp;
sub cluckweaken {
@_ == 1 or fp_croak_arity 1;
cluck "weaken ($_[0])";
Scalar::Util::weaken($_[0]);
}
sub cluckWeakened {
@_ == 1 or fp_croak_arity 1;
cluck "weaken ($_[0])";
Weakened($_[0]);
}
sub with_cluckweaken (&) { local $weaken = \&cluckweaken; &{ $_[0] }() }
sub do_weaken {
@_ == 1 or fp_croak_arity 1;
my ($v) = @_;
my $w = $v
? (
+{
1 => \&Scalar::Util::weaken,
"yes" => \&Scalar::Util::weaken,
"no" => \&noweaken,
"on" => \&Scalar::Util::weaken,
"off" => \&noweaken,
"noweaken" => \&noweaken,
"warn" => \&warnweaken,
"warnweaken" => \&warnweaken,
"cluck" => \&cluckweaken,
"cluckweaken" => \&cluckweaken,
}->{$v} // die "do_weaken: unknown key '$v'"
)
: \&noweaken;
$weaken = $w
}
1
lib/FP/Weak/t.pm view on Meta::CPAN
use strict;
use warnings;
use warnings FATAL => 'uninitialized';
use FP::Weak ":all";
use Chj::TEST;
sub t {
my $foo = [];
weaken $foo;
$foo
}
TEST { my $foo = []; noweaken $foo; $foo }
[];
TEST {t}
undef;
TEST {
with_noweaken {t}
}
[];
TEST { &with_noweaken(\&t) }
[];
TEST {t}
undef;
TEST {
my @w;
local $SIG{__WARN__} = sub {
my ($msg) = @_;
$msg =~ s/0x[0-9a-f]*/0x.../s;
$msg =~ s/ at .*/ .../s;
push @w, $msg
};
[&with_warnweaken(\&t), @w]
}
[undef, "weaken (ARRAY(0x...)) ..."];
1
lib/FP/fix.pm view on Meta::CPAN
fix takes a function and returns another function that when called
calls the original function and gives it the fix'ed function as first
argument and then the original arguments.
This allows to write self-recursive local functions without having to
deal with the problem of reference cycles that self-referencing
closures would run into.
The example from the synopsis is equivalent to:
use Scalar::Util 'weaken';
sub fact2 {
my ($z) = @_;
my $f; $f = sub {
my ($x, $y) = @_;
$x > 0 ? $f->($x-1, $x*$y) : $y
};
my $_f = $f; weaken $f;
$f->($z, 1)
}
is fact2(5), 120;
=head1 NOTE
This is alpha software! Read the status section in the package README
or on the L<website|http://functional-perl.org/>.
lib/FP/fix.pm view on Meta::CPAN
my ($f) = @_;
sub {
#@_ = (fix ($f), @_); goto &$f;
unshift @_, fix($f);
goto &$f;
}
};
# directly locally self-referencing
use Scalar::Util 'weaken';
use FP::Carp;
*weakcycle = sub {
@_ == 1 or fp_croak_arity 1;
my ($f) = @_;
my $f2;
$f2 = sub {
unshift @_, $f2;
goto &$f
};
my $f2_ = $f2;
weaken $f2;
$f2_
};
# choose implementation:
sub fix;
*fix = \&weakcycle;
# n-ary version:
lib/FP/fix.pm view on Meta::CPAN
my @ff;
for (my $i = 0; $i < @f; $i++) {
my $f = $f[$i];
$ff[$i] = sub {
unshift @_, @ff;
goto &$f;
}
}
my @ff_ = @ff;
# weaken $_ for @ff;
# ^ XXX: releases too early, same issue as
# mentioned in `intro/more_tailcalls`
wantarray ? @ff_ : do { ## no critic
@ff == 1 or die "fixn: got multiple arguments, but scalar context";
$ff_[0]
}
}
1
lib/PXML/Serialize.pm view on Meta::CPAN
);
our %EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);
use FP::Show;
use PXML::Element;
use PXML qw(is_pxml_element is_pxmlflush);
use FP::Lazy;
use FP::List;
use FP::Stream;
use Chj::xperlfunc qw(xprint xprintln);
use FP::Weak 'weaken'; # instead of from Scalar::Util so that it can
# be turned off globally (and we depend on FP
# anyway)
use Scalar::Util qw(blessed refaddr);
use FP::Carp;
sub is_somearray {
@_ == 1 or fp_croak_arity 1;
my $r = ref($_[0]);
# XX mess, make this a proper dependency
lib/PXML/Serialize.pm view on Meta::CPAN
} else {
# fast path:
attribute_escape $v
}
}
sub _pxml_print_fragment_fast {
@_ == 4 or fp_croak_arity 4;
my ($v, $fh, $html5compat, $void_element_h) = @_;
weaken $_[0]
# necessary since we're also called with strings:
if ref $_[0];
LP: {
## **NOTE**: this has seen some evil optimizations; before
## working on the code, please undo them first by using git
## revert.
if (my $ref = ref $v) {
if (defined(my $class = blessed $v)) {
if (
lib/PXML/Serialize.pm view on Meta::CPAN
#print $fh content_escape($v) or die $!;
$v =~ s/([&<>])/$content_escape{$1}/sg;
print $fh $v or die $!;
}
}
}
sub pxml_print_fragment_fast {
@_ == 2 or fp_croak_arity 2;
my ($v, $fh) = @_;
weaken $_[0] if ref $_[0]; # ref check perhaps unnecessary here
my $no_element = sub {
@_ = ($v, $fh, undef, undef);
goto \&_pxml_print_fragment_fast;
};
my $with_first_element = sub {
my ($firstel) = @_;
weaken $_[0] if ref $_[0];
my $html5compat
= $firstel->require_printing_nonvoid_elements_nonselfreferential;
@_ = ($v, $fh, $html5compat,
($html5compat and $firstel->void_element_h));
goto \&_pxml_print_fragment_fast;
};
if (length(my $r = ref $v)) {
if (defined blessed $v and $v->isa("PXML::XHTML")) {
@_ = ($v);
goto &$with_first_element;
lib/PXML/Serialize.pm view on Meta::CPAN
}
}
} else {
goto &$no_element
}
}
sub pxml_xhtml_print_fast {
@_ >= 2 and @_ <= 3 or fp_croak_arity "2-3";
my ($v, $fh, $maybe_lang) = @_;
weaken $_[0] if ref $_[0]; # ref check perhaps unnecessary here
if (not ref $v or (defined(blessed $v) and not $v->isa("PXML::Element"))) {
die "not an element: " . (show $v);
}
if (not "html" eq $v->name) {
die "not an 'html' element: " . (show $v);
}
xprint($fh, "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n");
xprint($fh,
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">\n"
);
lib/PXML/Serialize.pm view on Meta::CPAN
# for now,
sub pxml_xhtml_print;
*pxml_xhtml_print = \&pxml_xhtml_print_fast;
use Chj::xopen "xopen_write";
sub pxml_print {
@_ == 2 or fp_croak_arity 2;
my ($v, $fh) = @_;
weaken $_[0] if ref $_[0]; # ref check perhaps unnecessary here
xprintln($fh, q{<?xml version="1.0"?>});
pxml_print_fragment_fast($v, $fh);
}
sub putxmlfile {
@_ == 2 or fp_croak_arity 2;
my ($path, $xml) = @_;
weaken $_[1] if ref $_[0]; # ref check perhaps unnecessary here
my $f = xopen_write $path;
binmode($f, ":utf8") or die "binmode";
# ^ XX should this use ":encoding(UTF-8)"? To validate in-memory
# strings? Shouldn't we just check all *inputs*?
pxml_print($xml, $f);
$f->xclose;
}
sub PXML::Element::xmlfile {
my ($v, $path) = @_;
weaken $_[0];
putxmlfile($path, $v)
}
sub puthtmlfile {
@_ >= 2 and @_ <= 3 or fp_croak_arity "2-3";
my ($path, $v, $maybe_lang) = @_;
weaken $_[1] if ref $_[0]; # ref check perhaps unnecessary here
#xmkdir_p dirname $path;
my $out = xopen_write($path);
binmode $out, ":utf8" or die "binmode";
# ^ XX dito, see comment in putxmlfile
pxml_xhtml_print_fast($v, $out, $maybe_lang || "en");
$out->xclose;
}
sub PXML::Element::htmlfile {
my ($v, $path, $maybe_lang) = @_;
weaken $_[0];
puthtmlfile($path, $v, $maybe_lang)
}
1
t/perl-weaken-coderef-correctness.t view on Meta::CPAN
use strict;
use warnings;
use warnings FATAL => 'uninitialized';
use lib "./lib";
use Chj::xperlfunc ":all";
require "./meta/find-perl.pl";
# test t/perl-weaken-coderef without memory pressure, to check code
# correctness aside memory behaviour
$ENV{TEST_PERL} = 1;
$ENV{N} = 800;
$ENV{RES} = 320400;
xexec_safe $^X, "t/perl-weaken-coderef.t";
t/perl-weaken-coderef.t view on Meta::CPAN
require "./meta/readin.pl";
require "./meta/find-perl.pl";
use Test::More;
require "./testmem.pl";
setlimit_mem_MB($^V->{version}[1] < 15 ? 30 : 80);
is readin("perl t/perl/weaken-coderef 2 50000 |"), "3\n";
my $n = $ENV{N} // 80000;
my $res = ($ENV{RES} // 3200040000) . "\n";
is readin("perl t/perl/weaken-coderef $n 1 |"), $res;
SKIP: {
skip "Perl issue", 3 unless $ENV{TEST_PERL};
# XXX is this really a perl issue?
is readin("perl t/perl/weaken-coderef-alternative-fix Y $n 1 |"), $res;
is readin("perl t/perl/weaken-coderef-alternative-fix rec $n 1 |"), $res;
is readin(
"perl t/perl/weaken-coderef-alternative-fix haskell_uncurried $n 1 |"),
$res;
is readin("perl t/perl/weaken-coderef-alternative-fix '' $n 1 |"), $res;
}
done_testing;
t/perl/weaken-coderef view on Meta::CPAN
# Copyright (c) 2015-2020 Christian Jaeger, copying@christianjaeger.ch
# This is free software. See the file COPYING.md that came bundled
# with this file.
use strict;
use warnings;
use warnings FATAL => 'uninitialized';
use Test::Requires qw(BSD::Resource);
import BSD::Resource;
use Scalar::Util "weaken";
use FP::Carp;
sub rss {
@_ == 0 or fp_croak_arity 0;
(BSD::Resource::getrusage(BSD::Resource::RUSAGE_SELF()))[2]
}
sub naturals {
my $f;
$f = sub {
my ($n) = @_;
my $f = $f;
sub {
if ($n > 0) { [$n, &$f($n - 1)] }
else {
undef
}
}
};
my $f_ = $f;
weaken $f;
goto &$f_;
}
sub stream_sum {
my ($s) = @_;
#weaken $_[0];
# ^ not necessary here, since, unlike with FP::Lazy::Promise,
# resulting value is not saved in its 'generating container'
my $tot = 0;
LP: {
if (my $fs = &$s) {
($tot, $s) = ($$fs[0] + $tot, $$fs[1]);
goto LP;
} else {
$tot
}
t/perl/weaken-coderef-alternative view on Meta::CPAN
#!/usr/bin/env perl
# Copyright (c) 2015 Christian Jaeger, copying@christianjaeger.ch
# This is free software. See the file COPYING.md that came bundled
# with this file.
use strict;
use warnings;
use warnings FATAL => 'uninitialized';
use Scalar::Util "weaken";
sub foo {
my $f = sub {
my ($f, $n) = @_;
sub {
if ($n > 0) {
$n + &{ &$f($f, $n - 1) }
} else {
0
}
t/perl/weaken-coderef-alternative-FP view on Meta::CPAN
use Cwd 'abs_path';
our ($mydir, $myname);
BEGIN {
my $location = (-l $0) ? abs_path($0) : $0;
$location =~ /(.*?)([^\/]+?)_?\z/s or die "?";
($mydir, $myname) = ($1, $2);
}
use lib "$mydir/../../lib";
use Scalar::Util 'weaken';
@ARGV == 3 or die "usage: $0 impl n m";
our ($impl, $n, $m) = @ARGV;
use FP::List ":all";
use FP::Lazy ":all";
sub naturals {
my $f;
$f = sub {
t/perl/weaken-coderef-alternative-FP view on Meta::CPAN
my $f = $f;
lazy {
if ($n > 0) {
cons $n, &$f($n - 1)
} else {
null
}
}
};
my $f_ = $f;
weaken $f;
goto &$f_;
}
sub stream_sum {
my ($s) = @_;
weaken $_[0];
# ^ not necessary here, since, unlike with FP::Lazy::Promise,
# resulting value is not saved in its 'generating container'
my $lp;
$lp = sub {
my ($tot, $s) = @_;
weaken $_[1];
FORCE $s;
if (is_null $s) {
$tot
} else {
@_ = (car($s) + $tot, cdr $s);
goto &$lp;
}
};
@_ = (0, $s);
my $lp_ = $lp;
weaken $lp;
goto &$lp_;
}
my $res;
for (1 .. $m) {
my $ns = naturals $n;
$res = stream_sum $ns;
}
print $res, "\n";
t/perl/weaken-coderef-alternative-fix view on Meta::CPAN
use Cwd 'abs_path';
our ($mydir, $myname);
BEGIN {
my $location = (-l $0) ? abs_path($0) : $0;
$location =~ /(.*?)([^\/]+?)_?\z/s or die "?";
($mydir, $myname) = ($1, $2);
}
use lib "$mydir/../../lib";
use Scalar::Util 'weaken';
@ARGV == 3 or die "usage: $0 impl n m";
our ($impl, $n, $m) = @ARGV;
use FP::fix;
if ($impl) {
$impl =~ /^\w+\z/ or die "invalid arg";
undef *fix;
*fix = eval '\&FP::fix::' . $impl;
t/perl/weaken-coderef-alternative-fix view on Meta::CPAN
else {
undef
}
}
};
goto &$f;
}
sub stream_sum {
my ($s) = @_;
weaken $_[0];
# ^ not necessary here, since, unlike with FP::Lazy::Promise,
# resulting value is not saved in its 'generating container'
my $lp = fix sub {
my ($lp, $tot, $s) = @_;
weaken $_[2];
if (my $fs = &$s) {
@_ = ($$fs[0] + $tot, $$fs[1]);
goto &$lp;
} else {
$tot
}
};
@_ = (0, $s);
my $lp_ = $lp;
weaken $lp;
goto &$lp_;
}
my $res;
for (1 .. $m) {
my $ns = naturals $n;
$res = stream_sum $ns;
}
print $res, "\n";
t/perl/weaken-coderef-simplified view on Meta::CPAN
#!/usr/bin/env perl
# Copyright (c) 2015 Christian Jaeger, copying@christianjaeger.ch
# This is free software. See the file COPYING.md that came bundled
# with this file.
use strict;
use warnings;
use warnings FATAL => 'uninitialized';
use Scalar::Util "weaken";
sub foo {
my $f;
$f = sub {
my ($n) = @_;
my $f = $f; # create a new, strong binding for f to prevent it
# from being freed (upon return from f)
sub {
if ($n > 0) {
$n + &{ &$f($n - 1) }
} else {
0
}
}
};
my $f_ = $f;
weaken $f;
&$f_;
}
my $res = &{ foo 2 };
print $res, "\n";
website/gen-config.pl view on Meta::CPAN
type => "text/css"
}
)
},
header => sub($path0) {
# HTML above navigation
# XX hack: clone it so that serialization doesn't kill parts of
# it (by way of `weaken`ing)
clone $logocfg->($path0)->{logo}
},
nav => nav(
entry(
"README.md", entry("docs/intro.md"),
entry("docs/howto.md"), entry("docs/design.md"),
entry("examples/README.md")
),
entry("functional_XML/README.md", entry("functional_XML/TODO.md")),
entry("htmlgen/README.md", entry("htmlgen/TODO.md")),
( run in 0.813 second using v1.01-cache-2.11-cpan-65fba6d93b7 )