[libcatmandu-perl] 24/85: Fixing maybe and 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 b28cbc284e0836eda0d5ee0a578b4485adf8dc51
Author: Patrick Hochstenbach <patrick.hochstenbach at ugent.be>
Date:   Sun May 11 20:21:38 2014 +0200

    Fixing maybe and list monad
---
 lib/Catmandu/Fix/Bind.pm       |  2 +-
 lib/Catmandu/Fix/Bind/list.pm  | 22 ++++++----------------
 lib/Catmandu/Fix/Bind/maybe.pm | 20 ++++++--------------
 t/Catmandu-Fix-Bind-list.t     |  2 +-
 t/Catmandu-Fix-Bind-maybe.t    |  6 +++---
 5 files changed, 17 insertions(+), 35 deletions(-)

diff --git a/lib/Catmandu/Fix/Bind.pm b/lib/Catmandu/Fix/Bind.pm
index 89973d4..3b652b4 100644
--- a/lib/Catmandu/Fix/Bind.pm
+++ b/lib/Catmandu/Fix/Bind.pm
@@ -13,7 +13,7 @@ around bind => sub {
     my ($orig, $self, $prev, @args) = @_;
     my $next = $orig->($self,$prev, at args);
 
-    if ($self->can('plus') && $self->can('zero')) {
+    if ($self->can('plus')) {
         return $self->plus($prev,$next);
     }
     else {
diff --git a/lib/Catmandu/Fix/Bind/list.pm b/lib/Catmandu/Fix/Bind/list.pm
index 15a82ab..4793270 100644
--- a/lib/Catmandu/Fix/Bind/list.pm
+++ b/lib/Catmandu/Fix/Bind/list.pm
@@ -13,21 +13,6 @@ sub zero {
 	[];
 }
 
-sub plus {
-	my ($self,$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 {
 	my ($self,$data) = @_;
 
@@ -46,13 +31,18 @@ sub bind {
 	my ($self,$mvar,$func,$name) = @_;
 
 	if (Catmandu::Util::is_array_ref($mvar)) {
-		[ map { $func->($_) } @$mvar ];
+		concat ( [ map { $func->($_) } @$mvar ] );
 	}
 	else {
 		return $self->zero;
 	}
 }
 
+# Flatten an array: [ [A] , [A] , [A] ] -> [ A, A, A]
+sub concat {
+	[ map { Catmandu::Util::is_array_ref($_) ? @$_ : $_ } @{$_[0]} ];
+}
+
 =head1 NAME
 
 Catmandu::Fix::Bind::maybe - a binder that computes Fix-es for every element in a list
diff --git a/lib/Catmandu/Fix/Bind/maybe.pm b/lib/Catmandu/Fix/Bind/maybe.pm
index c2867cc..234261b 100644
--- a/lib/Catmandu/Fix/Bind/maybe.pm
+++ b/lib/Catmandu/Fix/Bind/maybe.pm
@@ -8,32 +8,24 @@ with 'Catmandu::Fix::Bind';
 sub bind {
 	my ($self,$mvar,$func) = @_;
 
-	my $res;
-
-	eval {
-		$res = $func->($mvar);
-	};
-	if ($@) {
-		if (ref $@ eq 'Catmandu::Fix::Reject') {
-			die $@;
-		}
-		else {
-			return $mvar;
-		}
+	if (! defined $mvar) {
+		return undef;
 	}
+
+	my $res = $func->($mvar);
 	
 	$res;
 }
 
 =head1 NAME
 
-Catmandu::Fix::Bind::maybe - a binder that ignores all Fix functions that throw errors
+Catmandu::Fix::Bind::maybe - a binder that skips fixes is one returns undef
 
 =head1 SYNOPSIS
 
  do maybe()
 	foo()
-	throw_error() # will be ignored
+	return_undef() # rest will be ignored
 	bar()
  end
 
diff --git a/t/Catmandu-Fix-Bind-list.t b/t/Catmandu-Fix-Bind-list.t
index 5b69af9..d5d45df 100644
--- a/t/Catmandu-Fix-Bind-list.t
+++ b/t/Catmandu-Fix-Bind-list.t
@@ -15,7 +15,7 @@ BEGIN {
 require_ok $pkg;
 
 my $monad = Catmandu::Fix::Bind::list->new();
-my $f     = 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";
diff --git a/t/Catmandu-Fix-Bind-maybe.t b/t/Catmandu-Fix-Bind-maybe.t
index 2d46d80..776a391 100644
--- a/t/Catmandu-Fix-Bind-maybe.t
+++ b/t/Catmandu-Fix-Bind-maybe.t
@@ -1,10 +1,10 @@
 #!/usr/bin/env perl
-package Catmandu::Fix::throw_error;
+package Catmandu::Fix::undef_error;
 
 use Moo;
 
 sub fix {
-  die "eek!";
+   undef;
 }
 
 package main;
@@ -113,7 +113,7 @@ is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing nesting';
 
 $fixes =<<EOF;
 do maybe()
-  throw_error()
+  undef_error()
   add_field(foo,bar)
 end
 EOF

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libcatmandu-perl.git