[libcatmandu-perl] 23/85: Adding better support for reject via Catmandu::Fix::Reject classes and adding the list monad
Jonas Smedegaard
dr at jones.dk
Tue May 20 09:56:16 UTC 2014
This is an automated email from the git hooks/post-receive script.
js pushed a commit to tag 0.91
in repository libcatmandu-perl.
commit c2f9540067fb530ad99675744230da44c703c93a
Author: Patrick Hochstenbach <patrick.hochstenbach at ugent.be>
Date: Sun May 11 12:41:03 2014 +0200
Adding better support for reject via Catmandu::Fix::Reject classes and
adding the list monad
---
lib/Catmandu/Fix.pm | 2 +-
lib/Catmandu/Fix/Bind.pm | 12 ++++++++++++
lib/Catmandu/Fix/Bind/list.pm | 14 ++++++++++++--
t/Catmandu-Fix-Bind-list.t | 4 ++--
4 files changed, 27 insertions(+), 5 deletions(-)
diff --git a/lib/Catmandu/Fix.pm b/lib/Catmandu/Fix.pm
index cddb26e..8b6036c 100644
--- a/lib/Catmandu/Fix.pm
+++ b/lib/Catmandu/Fix.pm
@@ -127,7 +127,7 @@ sub emit {
$perl .= "} or do {";
$perl .= $self->emit_declare_vars($err, '$@');
# TODO throw Catmandu::Error
- $perl .= qq|if (${err} == ${reject_var}) { ${err} } else { die ${err}.Data::Dumper->Dump([${var}], [qw(data)]); }|;
+ $perl .= qq|if (ref(${err}) eq 'Catmandu::Fix::Reject') { ${err} } else { die ${err}.Data::Dumper->Dump([${var}], [qw(data)]); }|;
$perl .= "};";
$perl .= "};";
diff --git a/lib/Catmandu/Fix/Bind.pm b/lib/Catmandu/Fix/Bind.pm
index 1773c68..89973d4 100644
--- a/lib/Catmandu/Fix/Bind.pm
+++ b/lib/Catmandu/Fix/Bind.pm
@@ -9,6 +9,18 @@ requires 'bind';
has return => (is => 'rw', default => sub { [0]});
has fixes => (is => 'rw', default => sub { [] });
+around bind => sub {
+ my ($orig, $self, $prev, @args) = @_;
+ my $next = $orig->($self,$prev, at args);
+
+ if ($self->can('plus') && $self->can('zero')) {
+ return $self->plus($prev,$next);
+ }
+ else {
+ return $next;
+ }
+};
+
sub unit {
my ($self,$data) = @_;
return $data;
diff --git a/lib/Catmandu/Fix/Bind/list.pm b/lib/Catmandu/Fix/Bind/list.pm
index 93747d3..15a82ab 100644
--- a/lib/Catmandu/Fix/Bind/list.pm
+++ b/lib/Catmandu/Fix/Bind/list.pm
@@ -15,7 +15,17 @@ sub zero {
sub plus {
my ($self,$a,$b) = @_;
- push @$a , @$b;
+
+ if ($a == $self->zero || $b == $self->zero) {
+ return $self->zero;
+ }
+ elsif (Catmandu::Util::is_array_ref($b)) {
+ # Flatten the results
+ return [ grep {defined $_} (map { Catmandu::Util::is_array_ref($_) ? @$_ : $_ } @$b) ];
+ }
+ else {
+ $b;
+ }
}
sub unit {
@@ -36,7 +46,7 @@ sub bind {
my ($self,$mvar,$func,$name) = @_;
if (Catmandu::Util::is_array_ref($mvar)) {
- map { $func->($_) } @$mvar;
+ [ map { $func->($_) } @$mvar ];
}
else {
return $self->zero;
diff --git a/t/Catmandu-Fix-Bind-list.t b/t/Catmandu-Fix-Bind-list.t
index 4504ee4..5b69af9 100644
--- a/t/Catmandu-Fix-Bind-list.t
+++ b/t/Catmandu-Fix-Bind-list.t
@@ -15,8 +15,8 @@ BEGIN {
require_ok $pkg;
my $monad = Catmandu::Fix::Bind::list->new();
-my $f = sub { $_[0]->{demo} = 1 ; $_[0] };
-my $g = sub { $_[0]->{demo} += 1 ; $_[0] };
+my $f = sub { $_[0]->{demo} = 1 ; [ $_[0] ]; };
+my $g = sub { $_[0]->{demo} += 1 ; [ $_[0] ]; };
is_deeply $monad->bind( $monad->unit({}), $f) , $f->({}) , "left unit monadic law";
is_deeply $monad->bind( $monad->unit({}), sub { $monad->unit(shift) }) , $monad->unit({}) , "right unit monadic law";
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libcatmandu-perl.git
More information about the Pkg-perl-cvs-commits
mailing list