[libcatmandu-perl] 20/85: Adding the Maybe 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 1ae47da0789183353b045e4f895ad25fedcbae4c
Author: Patrick Hochstenbach <patrick.hochstenbach at ugent.be>
Date:   Sat May 10 21:00:02 2014 +0200

    Adding the Maybe monad
---
 lib/Catmandu/Fix/Bind.pm       |   2 +-
 lib/Catmandu/Fix/Bind/maybe.pm |  49 ++++++++++++++++
 t/Catmandu-Fix-Bind-maybe.t    | 126 +++++++++++++++++++++++++++++++++++++++++
 3 files changed, 176 insertions(+), 1 deletion(-)

diff --git a/lib/Catmandu/Fix/Bind.pm b/lib/Catmandu/Fix/Bind.pm
index db02454..bb9ecf1 100644
--- a/lib/Catmandu/Fix/Bind.pm
+++ b/lib/Catmandu/Fix/Bind.pm
@@ -62,7 +62,7 @@ sub emit_bind {
     $perl .= "${unit} = ${bind_var}->finally(${unit});" if $self->can('finally');
 
     my $reject = $fixer->capture($fixer->_reject);
-    $perl .= "return ${unit} if ${unit} == ${reject};";
+    $perl .= "return ${unit} if defined ${unit} && ${unit} == ${reject};";
     
     $perl;
 }
diff --git a/lib/Catmandu/Fix/Bind/maybe.pm b/lib/Catmandu/Fix/Bind/maybe.pm
new file mode 100644
index 0000000..b8975ca
--- /dev/null
+++ b/lib/Catmandu/Fix/Bind/maybe.pm
@@ -0,0 +1,49 @@
+package Catmandu::Fix::Bind::maybe;
+
+use Moo;
+use Data::Dumper;
+
+with 'Catmandu::Fix::Bind';
+
+sub bind {
+	my ($self,$mvar,$func) = @_;
+
+	my $res;
+
+	eval {
+		$res = $func->($mvar);
+	};
+	if ($@) {
+		return $mvar;
+	}
+	
+	$res;
+}
+
+=head1 NAME
+
+Catmandu::Fix::Bind::maybe - a binder that ignores all Fix functions that throw errors
+
+=head1 SYNOPSIS
+
+ do maybe()
+	foo()
+	throw_error() # will be ignored
+	bar()
+ end
+
+=head1 DESCRIPTION
+
+The maybe binder computes all the Fix function and ignores fixes that throw exceptions.
+
+=head1 AUTHOR
+
+hochsten L<hochsten at cpan.org>
+
+=head1 SEE ALSO
+
+L<Catmandu::Fix::Bind>
+
+=cut
+
+1;
\ No newline at end of file
diff --git a/t/Catmandu-Fix-Bind-maybe.t b/t/Catmandu-Fix-Bind-maybe.t
new file mode 100644
index 0000000..c89a3d5
--- /dev/null
+++ b/t/Catmandu-Fix-Bind-maybe.t
@@ -0,0 +1,126 @@
+#!/usr/bin/env perl
+package Catmandu::Fix::throw_error;
+
+use Moo;
+
+sub fix {
+  die "eek!";
+}
+
+package main;
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+use Catmandu::Fix;
+use Catmandu::Importer::Mock;
+use Catmandu::Util qw(:is);
+
+my $pkg;
+BEGIN {
+    $pkg = 'Catmandu::Fix::Bind::maybe';
+    use_ok $pkg;
+}
+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";
+is_deeply $monad->finally( $monad->unit({hello => 'world'} ) ) , {hello => 'world'} , "can we unwrap the monad?";
+
+my $fixes =<<EOF;
+do maybe()
+  add_field(foo,bar)
+end
+EOF
+
+my $fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+ok $fixer , 'create fixer';
+
+is_deeply $fixer->fix({}), {foo => 'bar'} , 'testing add_field';
+
+$fixes =<<EOF;
+do maybe()
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing zero fix functions';
+
+$fixes =<<EOF;
+do maybe()
+  unless exists(foo)
+  	add_field(foo,bar)
+  end
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+is_deeply $fixer->fix({}), {foo => 'bar'} , 'testing unless';
+
+$fixes =<<EOF;
+do maybe()
+  if exists(foo)
+  	add_field(foo2,bar)
+  end
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar', foo2 => 'bar'} , 'testing if';
+
+$fixes =<<EOF;
+do maybe()
+  reject exists(foo)
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+ok !defined $fixer->fix({foo => 'bar'}) , 'testing reject';
+
+$fixes =<<EOF;
+do maybe()
+  select exists(foo)
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing select';
+
+$fixes =<<EOF;
+do maybe()
+ do maybe()
+  do maybe()
+   add_field(foo,bar)
+  end
+ end
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing nesting';
+
+$fixes =<<EOF;
+do maybe()
+  throw_error()
+  add_field(foo,bar)
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'specific testing';
+
+done_testing 15;
\ 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