[libcatmandu-perl] 25/85: Maybe needs Just and Nothing and not undef (which is equal to eof)

[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 e410fa1675c1a801994ca621733c7a5056762f96
Author: Patrick Hochstenbach <patrick.hochstenbach at ugent.be>
Date:   Sun May 11 20:45:09 2014 +0200

    Maybe needs Just and Nothing and not undef (which is equal to eof)
---
 lib/Catmandu/Fix/Bind/maybe.pm | 52 ++++++++++++++++++++++++++++++++++++++----
 t/Catmandu-Fix-Bind-list.t     | 11 +--------
 t/Catmandu-Fix-Bind-maybe.t    | 11 +--------
 3 files changed, 50 insertions(+), 24 deletions(-)

diff --git a/lib/Catmandu/Fix/Bind/maybe.pm b/lib/Catmandu/Fix/Bind/maybe.pm
index 234261b..92173a7 100644
--- a/lib/Catmandu/Fix/Bind/maybe.pm
+++ b/lib/Catmandu/Fix/Bind/maybe.pm
@@ -2,19 +2,63 @@ package Catmandu::Fix::Bind::maybe;
 
 use Moo;
 use Data::Dumper;
+use Scalar::Util qw/reftype/;
 
 with 'Catmandu::Fix::Bind';
 
+# Copied from hiratara's Data::Monad::Maybe
+sub just {
+	my ($self, at values) = @_;
+	bless [@values] , __PACKAGE__;
+}
+
+sub nothing {
+	my ($self) = @_;
+	bless \(my $d = undef), __PACKAGE__;
+}
+
+sub is_nothing { reftype $_[0] ne 'ARRAY'  }
+
+sub value {
+    if (is_nothing($_[0])) {
+        {};
+    } else {
+        $_[0]->[0];
+    }
+}
+# ---
+
+sub unit {
+	my ($self,$data) = @_;
+	$self->just($data);
+}
+
 sub bind {
 	my ($self,$mvar,$func) = @_;
 
-	if (! defined $mvar) {
-		return undef;
+	if (is_nothing($mvar)) {
+		return $self->nothing;
 	}
 
-	my $res = $func->($mvar);
+	my $res;
+
+	eval { 
+
+		$res = $func->(value($mvar))
+	};
+	if ($@ && ref $@ eq 'Catmandu::Fix::Reject') {
+		die $@;
+	}
+	else {
+		return $self->nothing;
+	}  
 	
-	$res;
+	if (defined $res) {
+		return $self->just($res);
+	}
+	else {
+		return $self->nothing;
+	}
 }
 
 =head1 NAME
diff --git a/t/Catmandu-Fix-Bind-list.t b/t/Catmandu-Fix-Bind-list.t
index d5d45df..b092c92 100644
--- a/t/Catmandu-Fix-Bind-list.t
+++ b/t/Catmandu-Fix-Bind-list.t
@@ -14,15 +14,6 @@ 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] ]; };
-
-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";
-is_deeply $monad->bind( $monad->bind( $monad->unit({}), $f ) , $g )  ,
-          $monad->bind( $monad->unit({}) , sub { $monad->bind($f->($_[0]),$g) } ) , "associative monadic law";
-
 my $fixes =<<EOF;
 do list()
   add_field(foo,bar)
@@ -115,4 +106,4 @@ is_deeply $fixer->fix(
           ), {foo => [ {bar => 1 , test => 'bar'} , 
              {bar => 2 , test => 'bar'}]} , 'specific testing';
 
-done_testing 14;
\ No newline at end of file
+done_testing 11;
\ No newline at end of file
diff --git a/t/Catmandu-Fix-Bind-maybe.t b/t/Catmandu-Fix-Bind-maybe.t
index 776a391..63c6969 100644
--- a/t/Catmandu-Fix-Bind-maybe.t
+++ b/t/Catmandu-Fix-Bind-maybe.t
@@ -23,15 +23,6 @@ BEGIN {
 }
 require_ok $pkg;
 
-my $monad = Catmandu::Fix::Bind::maybe->new();
-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";
-is_deeply $monad->bind( $monad->bind( $monad->unit({}), $f ) , $g )  ,
-          $monad->bind( $monad->unit({}) , sub { $monad->bind($f->($_[0]),$g) } ) , "associative monadic law";
-
 my $fixes =<<EOF;
 do maybe()
   add_field(foo,bar)
@@ -122,4 +113,4 @@ $fixer = Catmandu::Fix->new(fixes => [$fixes]);
 
 is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'specific testing';
 
-done_testing 14;
\ No newline at end of file
+done_testing 11;
\ No newline at end of file

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