[libcatmandu-perl] 18/85: Deleted the loop and each monads and adding monadic laws into the tests
Jonas Smedegaard
dr at jones.dk
Tue May 20 09:56:15 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 341afe1d6b8b84768dec50f29a69063690f502d8
Author: Patrick Hochstenbach <patrick.hochstenbach at ugent.be>
Date: Sat May 10 20:15:20 2014 +0200
Deleted the loop and each monads and adding monadic laws into the tests
---
lib/Catmandu/Fix/Bind.pm | 123 +++++++++++++++++---------------
lib/Catmandu/Fix/Bind/benchmark.pm | 2 +-
lib/Catmandu/Fix/Bind/each.pm | 81 ---------------------
lib/Catmandu/Fix/Bind/loop.pm | 42 -----------
t/Catmandu-Fix-Bind-benchmark.t | 12 +++-
t/Catmandu-Fix-Bind-each.t | 142 -------------------------------------
t/Catmandu-Fix-Bind-identity.t | 12 +++-
t/Catmandu-Fix-Bind-loop.t | 120 -------------------------------
8 files changed, 87 insertions(+), 447 deletions(-)
diff --git a/lib/Catmandu/Fix/Bind.pm b/lib/Catmandu/Fix/Bind.pm
index 156aeaa..db02454 100644
--- a/lib/Catmandu/Fix/Bind.pm
+++ b/lib/Catmandu/Fix/Bind.pm
@@ -8,11 +8,6 @@ requires 'bind';
has fixes => (is => 'rw', default => sub { [] });
-sub zero {
- my ($self) = @_;
- +{};
-}
-
sub unit {
my ($self,$data) = @_;
return $data;
@@ -23,16 +18,6 @@ sub bind {
return $code->($data);
}
-sub plus {
- my ($self,$prev,$curr) = @_;
- if ($prev == $self->zero || $curr == $self->zero) {
- $self->zero;
- }
- else {
- $curr;
- }
-}
-
sub finally {
my ($self,$data) = @_;
$data;
@@ -54,26 +39,30 @@ sub emit_bind {
my $perl = "";
- my $monad = $fixer->capture($self);
- my $m_res = $fixer->generate_var;
+ my $bind_var = $fixer->capture($self);
+ my $unit = $fixer->generate_var;
- $perl .= "my ${m_res} = ${monad}->unit(${var});";
+ # Poor man's monads using global state. Should be a bit
+ # faster than nested binds. The finally method is required
+ # to unwrap monadic values again to perl Hashes that
+ # Catmandu::Fix can understand
+ $perl .= "my ${unit} = ${bind_var}->unit(${var});";
for my $pair (@$code) {
my $name = $pair->[0];
my $code = $pair->[1];
my $code_var = $fixer->capture($code);
- $perl .= "${m_res} = ${monad}->plus(${m_res},${monad}->bind(${m_res}, sub {";
+ $perl .= "${unit} = ${bind_var}->bind(${unit}, sub {";
$perl .= "${var} = shift;";
$perl .= $code;
$perl .= "${var}";
- $perl .= "},'$name',${code_var}));"
+ $perl .= "},'$name',${code_var});"
}
- $perl .= "${var} = ${monad}->finally(${m_res});" if $self->can('finally');
+ $perl .= "${unit} = ${bind_var}->finally(${unit});" if $self->can('finally');
my $reject = $fixer->capture($fixer->_reject);
- $perl .= "return ${var} if ${var} == ${reject};";
+ $perl .= "return ${unit} if ${unit} == ${reject};";
$perl;
}
@@ -103,7 +92,8 @@ Catmandu::Fix::Bind - a wrapper for Catmandu::Fix-es
fix3()
end
- # this will execute all the fixes as expected plus print to STDERR
+ # this will execute all the fixes as expected, and print to STDERR the following messages
+
executing fix1
executing fix2
executing fix3
@@ -114,7 +104,7 @@ Bind is a package that wraps Catmandu::Fix-es and other Catmandu::Bind-s togethe
the programmer further control on the excution of fixes. With Catmandu::Fix::Bind you can simulate
the 'before', 'after' and 'around' modifiers as found in Moo or Dancer.
-To wrap Fix functions, the Fix language has provided a 'do' statment:
+To wrap Fix functions, the Fix language has a 'do' statment:
do BIND
FIX1
@@ -122,6 +112,8 @@ To wrap Fix functions, the Fix language has provided a 'do' statment:
FIX3
end
+where BIND is a implementation of BIND and FIX1,...,FIXn are fix functions.
+
In the example above the BIND will wrap FIX1, FIX2 and FIX3.
A Catmandu::Fix::Bind needs to implement two methods: 'unit' and 'bind'.
@@ -130,62 +122,75 @@ A Catmandu::Fix::Bind needs to implement two methods: 'unit' and 'bind'.
=head2 unit($data)
-The unit method receives a Perl $data HASH and should return it. The 'unit' method is called on a
-Catmandu::Fix::Bind instance before all Fix methods are executed. A trivial implementation of 'unit' is:
+The unit method receives a Perl $data HASH and should return it, possibly converted to a new type.
+The 'unit' method is called before all Fix methods are executed. A trivial, but verbose, implementation
+of 'unit' is:
- # Wrap the data into an array
sub unit {
my ($self,$data) = @_;
- my $m_data = ['foobar',$data];
- return $m_data;
+ my $wrapped_data = $data;
+ return $wrapped_data;
}
-=head2 bind($m_data,$code,$name,$perl)
+=head2 bind($wrapped_data,$code,$name,$perl)
-The bind method is executed for every Catmandu::Fix method in the fixer. It receives the $data
-, which as wrapped by unit, the fix method as anonymous subroutine, the name of the fix and the actual perl
-code to run it. It should return the fixed code. A trivial implementaion of 'bind' is:
+The bind method is executed for every Catmandu::Fix method in the fix script. It receives the $wrapped_data
+(wrapped by 'unit'), the fix method as anonymous subroutine, the name of the fix and the actual perl
+code which runs it as a string. It should return data with the same type as returned by 'unit'.
+A trivial, but verbose, implementaion of 'bind' is:
- # Unwrap the data and execute the given code
sub bind {
- my ($self,$m_data,$code,$name) = @_;
- my ($foo, $data) = @$m_data
- my $res = $code->($data);
- ['foobar',$res];
+ my ($self,$wrapped_data,$code,$name,$perl) = @_;
+ my $data = $wrapped_data;
+ $data = $code->($data);
+ # we don't need to wrap it again because the $data and $wrapped_data have the same type
+ $data;
}
-=head2 zero
+=head2 finally($data)
-Optionally provide an zero unit in combining computations. E.g.
-
- sub zero {
- return undef;
+Optionally finally is executed at the end the 'do' block. This method should be an inverse of unit (unwrap the data).
+A trivial, but verbose, implementation of 'finally' is:
+
+ sub finally {
+ my ($self,$wrapped_data) = @_;
+ my $data = $wrapped_data;
+ $data;
}
-=head2 plus($prev,$curr)
+=head1 REQUIREMENTS
-Optionally provide a function to combine the results of two computations. E.g.
+Bind mmodules are simplified implementations of Monads. They should answer the formal definition of Monads, codified
+in 3 monadic laws:
- sub plus {
- my ($self,$prev,$curr) = @_;
- return $curr;
- }
+=head2 left unit: unit acts as a neutral element of bind
-=head2 finally($data)
+ my $monad = Catmandu::Fix::Bind->demo();
-Optionally finally is executed on the data when all the fixes in a do block have run. A trivial example of finally is:
+ # bind(unit(data), coderef) == coderef(data)
+ $monad->bind( $monad->unit({foo=>'bar'}) , $coderef) == $coderef->({foo=>'bar'});
- # Unwrap the data and return the original
- sub finally {
- my ($self,$m_data) = @_;
- my ($foo, $data) = @$m_data ;
- $data;
- }
+=head2 right unit: unit act as a neutral element of bind
+
+ # bind(unit(data), unit) == unit(data)
+ $monad->bind( $monad->unit({foo=>'bar'}) , sub { $monad->unit(shift) } ) == $monad->unit({foo=>'bar'});
+
+=head2 associative: chaining bind blocks should have the same effect as nesting them
+
+ # bind(bind(unit(data),f),g) == bind(unit(data), sub { return bind(f(data),g) } )
+ my $f = sub { my $data = shift; $data->{demo} = 1 ; $data };
+ my $g = sub { my $data = shift; $data->{demo} += 1 ; $data};
+
+ $monad->bind( $monad->bind( $monad->unit({}) , f ) , g ) ==
+ $monad->bind( $monad->unit({}) , sub { my $data = shift; $monad->bind($f->($data), $g ); $data; });
=head1 SEE ALSO
-L<Catmandu::Fix::Bind::identity>, L<Catmandu::Fix::Bind::each> , L<Catmandu::Fix::Bind::loop> ,
-L<Catmandu::Fix::Bind::eval>, L<Catmandu::Fix::Bind::benchmark>
+L<Catmandu::Fix::Bind::identity>, L<Catmandu::Fix::Bind::benchmark>
+
+=head1 AUTHOR
+
+Patrick Hochstenbach - L<Patrick.Hochstenbach at UGent.be>
=cut
diff --git a/lib/Catmandu/Fix/Bind/benchmark.pm b/lib/Catmandu/Fix/Bind/benchmark.pm
index 807b309..c398d20 100644
--- a/lib/Catmandu/Fix/Bind/benchmark.pm
+++ b/lib/Catmandu/Fix/Bind/benchmark.pm
@@ -15,7 +15,7 @@ sub _build_stats {
sub bind {
my ($self,$data,$code,$name) = @_;
-
+ $name = '<undef>' unless defined $name;
my $t0 = [gettimeofday];
$data = $code->($data);
my $elapsed = tv_interval ( $t0 );
diff --git a/lib/Catmandu/Fix/Bind/each.pm b/lib/Catmandu/Fix/Bind/each.pm
deleted file mode 100644
index f3958d3..0000000
--- a/lib/Catmandu/Fix/Bind/each.pm
+++ /dev/null
@@ -1,81 +0,0 @@
-package Catmandu::Fix::Bind::each;
-
-use Moo;
-use Catmandu::Util qw(:data :is);
-
-with 'Catmandu::Fix::Bind';
-
-has path => (is => 'ro' , required => 1);
-has index => (is => 'ro');
-has values => (is => 'rw', default => sub { [] });
-has promises => (is => 'rw', default => sub { [] });
-
-sub bind {
- my ($self,$data,$code,$name) = @_;
-
- my $value = data_at($self->path,$data);
-
- if (defined $value && is_array_ref($value)) {
- $self->values($value);
- push @{$self->promises} , [$code,$name];
- }
-
- $data;
-}
-
-sub finally {
- my ($self,$data) = @_;
-
- for my $i (@{$self->values}) {
- for my $promise (@{$self->promises}) {
- my ($code,$name) = @$promise;
- if (defined $self->index) {
- $data->{$self->index} = $i;
- }
- $data = $code->($data);
- }
- }
-
- if (defined $self->index) {
- delete $data->{$self->index};
- }
-
- $self->promises([]);
- $self->values([]);
-
- $data;
-}
-
-=head1 NAME
-
-Catmandu::Fix::Bind::each - loop over all the values in a path
-
-=head1 SYNOPSIS
-
- add_field(demo.$append,foo)
- add_field(demo.$append,bar)
-
- do each(path => demo, index => val)
- copy_field(val,demo2.$append)
- end
-
- # demo = ['foo' , 'bar'];
- # demo2 = ['foo' , 'bar'];
-
-=head1 PARAMETERS
-
-=head2 path (required)
-
-A path to an array ref over which the 'each' needs to loop
-
-=head2 index (optional)
-
-The name of an index field that gets populated for every value on the path
-
-=head1 SEE ALSO
-
-L<Catmandu::Fix::Bind>
-
-=cut
-
-1;
diff --git a/lib/Catmandu/Fix/Bind/loop.pm b/lib/Catmandu/Fix/Bind/loop.pm
deleted file mode 100644
index 72610e5..0000000
--- a/lib/Catmandu/Fix/Bind/loop.pm
+++ /dev/null
@@ -1,42 +0,0 @@
-package Catmandu::Fix::Bind::loop;
-
-use Moo;
-
-with 'Catmandu::Fix::Bind';
-
-has count => (is => 'ro' , default => sub { 1 } );
-has index => (is => 'ro');
-has promises => (is => 'rw', default => sub { [] });
-
-sub bind {
- my ($self,$data,$code,$name) = @_;
-
- push @{$self->promises} , [$code,$name];
-
- $data;
-}
-
-sub finally {
- my ($self,$data) = @_;
-
- for (my $i = 0 ; $i < $self->count ; $i++) {
-
- for my $promise (@{$self->promises}) {
- my ($code,$name) = @$promise;
- if (defined $self->index) {
- $data->{$self->index} = $i;
- }
- $data = $code->($data);
- }
- }
-
- if (defined $self->index) {
- delete $data->{$self->index};
- }
-
- $self->promises([]);
-
- $data;
-}
-
-1;
diff --git a/t/Catmandu-Fix-Bind-benchmark.t b/t/Catmandu-Fix-Bind-benchmark.t
index 8338be8..a670e51 100644
--- a/t/Catmandu-Fix-Bind-benchmark.t
+++ b/t/Catmandu-Fix-Bind-benchmark.t
@@ -14,6 +14,16 @@ BEGIN {
}
require_ok $pkg;
+my $monad = Catmandu::Fix::Bind::benchmark->new(output => '/dev/null');
+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 benchmark(output => /dev/null)
add_field(foo,bar)
@@ -93,4 +103,4 @@ $fixer = Catmandu::Fix->new(fixes => [$fixes]);
is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing nesting';
-done_testing 10;
\ No newline at end of file
+done_testing 14;
\ No newline at end of file
diff --git a/t/Catmandu-Fix-Bind-each.t b/t/Catmandu-Fix-Bind-each.t
deleted file mode 100644
index 81acab3..0000000
--- a/t/Catmandu-Fix-Bind-each.t
+++ /dev/null
@@ -1,142 +0,0 @@
-#!/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::each';
- use_ok $pkg;
-}
-require_ok $pkg;
-
-my $fixes =<<EOF;
-add_field(test.\$append,1)
-do each(path => test)
- add_field(foo,bar)
-end
-remove_field(test)
-EOF
-
-my $fixer = Catmandu::Fix->new(fixes => [$fixes]);
-
-ok $fixer , 'create fixer';
-
-is_deeply $fixer->fix({}), {foo => 'bar'} , 'testing add_field';
-
-$fixes =<<EOF;
-add_field(test.\$append,1)
-do each(path => test)
-end
-remove_field(test)
-EOF
-
-$fixer = Catmandu::Fix->new(fixes => [$fixes]);
-
-is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing zero fix functions';
-
-$fixes =<<EOF;
-add_field(test.\$append,1)
-do each(path => test)
- unless exists(foo)
- add_field(foo,bar)
- end
-end
-remove_field(test)
-EOF
-
-$fixer = Catmandu::Fix->new(fixes => [$fixes]);
-
-is_deeply $fixer->fix({}), {foo => 'bar'} , 'testing unless';
-
-$fixes =<<EOF;
-add_field(test.\$append,1)
-do each(path => test)
- if exists(foo)
- add_field(foo2,bar)
- end
-end
-remove_field(test)
-EOF
-
-$fixer = Catmandu::Fix->new(fixes => [$fixes]);
-
-is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar', foo2 => 'bar'} , 'testing if';
-
-$fixes =<<EOF;
-add_field(test.\$append,1)
-do each(path => test)
- reject exists(foo)
-end
-remove_field(test)
-EOF
-
-$fixer = Catmandu::Fix->new(fixes => [$fixes]);
-
-ok ! defined $fixer->fix({foo => 'bar'}) , 'testing reject';
-
-$fixes =<<EOF;
-add_field(test.\$append,1)
-do each(path => test)
- select exists(foo)
-end
-remove_field(test)
-EOF
-
-$fixer = Catmandu::Fix->new(fixes => [$fixes]);
-
-is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing select';
-
-$fixes =<<EOF;
-add_field(test.\$append,1)
-do each(path => test)
- do each(path => test)
- do each(path => test)
- add_field(foo,bar)
- end
- end
-end
-remove_field(test)
-EOF
-
-$fixer = Catmandu::Fix->new(fixes => [$fixes]);
-
-is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing nesting';
-
-$fixes =<<EOF;
-add_field(test.\$append,0)
-add_field(test.\$append,1)
-add_field(test.\$append,2)
-do each(path => test, index => i)
- copy_field(i,demo.\$append)
- copy_field(i,demo2.\$append)
-end
-remove_field(test)
-EOF
-
-$fixer = Catmandu::Fix->new(fixes => [$fixes]);
-
-is_deeply $fixer->fix({}), {demo => [(qw(0 1 2))] , demo2 => [qw(0 1 2 )]} , 'testing specific loop';
-
-$fixes =<<EOF;
-add_field(test.\$append,0)
-add_field(test.\$append,1)
-add_field(test.\$append,2)
-do each(path => test, index => i)
- copy_field(i,demo.\$append)
- do loop(count => 3)
- copy_field(i,demo2.\$append)
- end
-end
-remove_field(test)
-EOF
-
-$fixer = Catmandu::Fix->new(fixes => [$fixes]);
-
-is_deeply $fixer->fix({}), {demo => [(qw(0 1 2))] , demo2 => [qw(0 0 0 1 1 1 2 2 2)]} , 'testing specific loop';
-
-done_testing 12;
\ No newline at end of file
diff --git a/t/Catmandu-Fix-Bind-identity.t b/t/Catmandu-Fix-Bind-identity.t
index b5989e6..e60868b 100644
--- a/t/Catmandu-Fix-Bind-identity.t
+++ b/t/Catmandu-Fix-Bind-identity.t
@@ -14,6 +14,16 @@ BEGIN {
}
require_ok $pkg;
+my $monad = Catmandu::Fix::Bind::identity->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 identity()
add_field(foo,bar)
@@ -93,4 +103,4 @@ $fixer = Catmandu::Fix->new(fixes => [$fixes]);
is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing nesting';
-done_testing 10;
\ No newline at end of file
+done_testing 14;
\ No newline at end of file
diff --git a/t/Catmandu-Fix-Bind-loop.t b/t/Catmandu-Fix-Bind-loop.t
deleted file mode 100644
index be05ed1..0000000
--- a/t/Catmandu-Fix-Bind-loop.t
+++ /dev/null
@@ -1,120 +0,0 @@
-#!/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::loop';
- use_ok $pkg;
-}
-require_ok $pkg;
-
-my $fixes =<<EOF;
-do loop(count => 1)
- 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 loop(count => 1)
-end
-EOF
-
-$fixer = Catmandu::Fix->new(fixes => [$fixes]);
-
-is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing zero fix functions';
-
-$fixes =<<EOF;
-do loop(count => 1)
- 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 loop(count => 1)
- 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 loop(count => 1)
- reject exists(foo)
-end
-EOF
-
-$fixer = Catmandu::Fix->new(fixes => [$fixes]);
-
-ok ! defined $fixer->fix({foo => 'bar'}) , 'testing reject';
-
-$fixes =<<EOF;
-do loop(count => 1)
- select exists(foo)
-end
-EOF
-
-$fixer = Catmandu::Fix->new(fixes => [$fixes]);
-
-is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing select';
-
-$fixes =<<EOF;
-do loop(count => 1)
- do loop(count => 1)
- do loop(count => 1)
- 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 loop(count => 3 , index => i)
- copy_field(i,demo.\$append)
- copy_field(i,demo2.\$append)
-end
-EOF
-
-$fixer = Catmandu::Fix->new(fixes => [$fixes]);
-
-is_deeply $fixer->fix({}), {demo => [(qw(0 1 2))] , demo2 => [qw(0 1 2 )]} , 'testing specific loop';
-
-$fixes =<<EOF;
-do loop(count => 3 , index => i)
- copy_field(i,demo.\$append)
- do loop(count => 3)
- copy_field(i,demo2.\$append)
- end
-end
-EOF
-
-$fixer = Catmandu::Fix->new(fixes => [$fixes]);
-
-is_deeply $fixer->fix({}), {demo => [(qw(0 1 2))] , demo2 => [qw(0 0 0 1 1 1 2 2 2)]} , 'testing specific loop';
-
-done_testing 12;
--
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