[libcatmandu-perl] 22/85: 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 dadf3afe37e878ad6b4fa6dbb772a92549ee3785
Author: Patrick Hochstenbach <patrick.hochstenbach at ugent.be>
Date: Sun May 11 09:25:09 2014 +0200
Adding the list monad
---
lib/Catmandu/Fix.pm | 11 ++--
lib/Catmandu/Fix/Bind.pm | 6 +--
lib/Catmandu/Fix/Bind/list.pm | 86 ++++++++++++++++++++++++++++++
lib/Catmandu/Fix/Bind/maybe.pm | 7 ++-
t/Catmandu-Fix-Bind-list.t | 118 +++++++++++++++++++++++++++++++++++++++++
5 files changed, 220 insertions(+), 8 deletions(-)
diff --git a/lib/Catmandu/Fix.pm b/lib/Catmandu/Fix.pm
index 0ea2bd9..cddb26e 100644
--- a/lib/Catmandu/Fix.pm
+++ b/lib/Catmandu/Fix.pm
@@ -1,3 +1,7 @@
+package Catmandu::Fix::Reject;
+
+use Moo;
+
package Catmandu::Fix;
use Catmandu::Sane;
@@ -25,7 +29,7 @@ has _num_vars => (is => 'rw', lazy => 1, init_arg => undef, default => sub { 0
has _captures => (is => 'ro', lazy => 1, init_arg => undef, default => sub { +{}; });
has var => (is => 'ro', lazy => 1, init_arg => undef, builder => 'generate_var');
has fixes => (is => 'ro', required => 1, trigger => 1);
-has _reject => (is => 'ro', init_arg => undef, default => sub { +{} });
+has _reject => (is => 'ro', init_arg => undef, default => sub { Catmandu::Fix::Reject->new; });
has _reject_var => (is => 'ro', lazy => 1, init_arg => undef, builder => '_build_reject_var');
sub _build_parser {
@@ -109,6 +113,7 @@ sub emit {
my $var = $self->var;
my $err = $self->generate_var;
my $captures = $self->_captures;
+ my $reject_var = $self->_reject_var;
my $perl = "";
$perl .= "sub {";
@@ -122,7 +127,7 @@ sub emit {
$perl .= "} or do {";
$perl .= $self->emit_declare_vars($err, '$@');
# TODO throw Catmandu::Error
- $perl .= qq|die ${err}.Data::Dumper->Dump([${var}], [qw(data)]);|;
+ $perl .= qq|if (${err} == ${reject_var}) { ${err} } else { die ${err}.Data::Dumper->Dump([${var}], [qw(data)]); }|;
$perl .= "};";
$perl .= "};";
@@ -174,7 +179,7 @@ sub emit_fixes {
sub emit_reject {
my ($self) = @_;
my $reject_var = $self->_reject_var;
- "return $reject_var;";
+ "die $reject_var;";
}
sub emit_fix {
diff --git a/lib/Catmandu/Fix/Bind.pm b/lib/Catmandu/Fix/Bind.pm
index 54dbd66..1773c68 100644
--- a/lib/Catmandu/Fix/Bind.pm
+++ b/lib/Catmandu/Fix/Bind.pm
@@ -16,7 +16,7 @@ sub unit {
sub bind {
my ($self,$data,$code,$name,$perl) = @_;
- return $code->($data);
+ return $code->($data);
}
sub emit {
@@ -37,6 +37,7 @@ sub emit_bind {
my $bind_var = $fixer->capture($self);
my $unit = $fixer->generate_var;
+ my $reject = $fixer->capture($fixer->_reject);
$perl .= "my ${unit} = ${bind_var}->unit(${var});";
@@ -50,9 +51,6 @@ sub emit_bind {
$perl .= "${var}";
$perl .= "},'$name',${code_var});"
}
-
- my $reject = $fixer->capture($fixer->_reject);
- $perl .= "return ${unit} if defined ${unit} && ${unit} == ${reject};";
if ($self->return) {
$perl .= "return ${unit};";
diff --git a/lib/Catmandu/Fix/Bind/list.pm b/lib/Catmandu/Fix/Bind/list.pm
new file mode 100644
index 0000000..93747d3
--- /dev/null
+++ b/lib/Catmandu/Fix/Bind/list.pm
@@ -0,0 +1,86 @@
+package Catmandu::Fix::Bind::list;
+
+use Moo;
+use Data::Dumper;
+use Catmandu::Util;
+
+with 'Catmandu::Fix::Bind';
+
+has path => (is => 'ro');
+
+sub zero {
+ my ($self) = @_;
+ [];
+}
+
+sub plus {
+ my ($self,$a,$b) = @_;
+ push @$a , @$b;
+}
+
+sub unit {
+ my ($self,$data) = @_;
+
+ if (defined $self->path) {
+ Catmandu::Util::data_at($self->path,$data);
+ }
+ elsif (Catmandu::Util::is_array_ref($data)) {
+ $data;
+ }
+ else {
+ [$data];
+ }
+}
+
+sub bind {
+ my ($self,$mvar,$func,$name) = @_;
+
+ if (Catmandu::Util::is_array_ref($mvar)) {
+ map { $func->($_) } @$mvar;
+ }
+ else {
+ return $self->zero;
+ }
+}
+
+=head1 NAME
+
+Catmandu::Fix::Bind::maybe - a binder that computes Fix-es for every element in a list
+
+=head1 SYNOPSIS
+
+ add_field(demo.$append.test,1)
+ add_field(demo.$append.test,2)
+
+ do list(path => demo)
+ add_field(foo,bar)
+ end
+
+ # will produce
+ demo:
+ - test: 1
+ foo: bar
+ - test: 2
+ foo: bar
+
+=head1 DESCRIPTION
+
+The list binder will iterate over all the elements in a list and fixes the values in context of that list.
+
+=head1 CONFIGURATION
+
+=head2 path
+
+The path to a list in the data.
+
+=head1 AUTHOR
+
+Patrick Hochstenbach <Patrick . Hochstenbach @ UGent . be >
+
+=head1 SEE ALSO
+
+L<Catmandu::Fix::Bind>
+
+=cut
+
+1;
\ No newline at end of file
diff --git a/lib/Catmandu/Fix/Bind/maybe.pm b/lib/Catmandu/Fix/Bind/maybe.pm
index c324c9b..c2867cc 100644
--- a/lib/Catmandu/Fix/Bind/maybe.pm
+++ b/lib/Catmandu/Fix/Bind/maybe.pm
@@ -14,7 +14,12 @@ sub bind {
$res = $func->($mvar);
};
if ($@) {
- return $mvar;
+ if (ref $@ eq 'Catmandu::Fix::Reject') {
+ die $@;
+ }
+ else {
+ return $mvar;
+ }
}
$res;
diff --git a/t/Catmandu-Fix-Bind-list.t b/t/Catmandu-Fix-Bind-list.t
new file mode 100644
index 0000000..4504ee4
--- /dev/null
+++ b/t/Catmandu-Fix-Bind-list.t
@@ -0,0 +1,118 @@
+#!/usr/bin/env perl
+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::list';
+ use_ok $pkg;
+}
+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)
+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 list()
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing zero fix functions';
+
+$fixes =<<EOF;
+do list()
+ 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 list()
+ 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 list()
+ reject exists(foo)
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+ok !defined $fixer->fix({foo => 'bar'}) , 'testing reject';
+
+$fixes =<<EOF;
+do list()
+ select exists(foo)
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing select';
+
+$fixes =<<EOF;
+do list()
+ do list()
+ do list()
+ 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 list(path => foo)
+ add_field(test,bar)
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+is_deeply $fixer->fix(
+ {foo => [ {bar => 1}, {bar => 2} ]}
+ ), {foo => [ {bar => 1 , test => 'bar'} ,
+ {bar => 2 , test => 'bar'}]} , 'specific testing';
+
+done_testing 14;
\ 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
More information about the Pkg-perl-cvs-commits
mailing list