[libcatmandu-perl] 23/85: Adding better support for reject via Catmandu::Fix::Reject classes and adding the list monad

[Jonas Smedegaard]

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.hochstenb...@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,@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

_______________________________________________
Pkg-perl-cvs-commits mailing list
Pkg-perl-cvs-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits