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.hochstenb...@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.hochstenb...@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 _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits