[libcatmandu-perl] 21/85: Adding a doset syntax
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 828f0ad4bd45dab59098350c2c33b28c1d12c5d1
Author: Patrick Hochstenbach <patrick.hochstenbach at ugent.be>
Date: Sun May 11 08:08:46 2014 +0200
Adding a doset syntax
---
lib/Catmandu/Fix/Bind.pm | 67 ++++++++++++++++++++++----------------
lib/Catmandu/Fix/Bind/benchmark.pm | 2 +-
lib/Catmandu/Fix/Bind/identity.pm | 2 +-
lib/Catmandu/Fix/Bind/maybe.pm | 2 +-
lib/Catmandu/Fix/Parser.pm | 12 +++++++
t/Catmandu-Fix-Bind-benchmark.t | 3 +-
t/Catmandu-Fix-Bind-identity.t | 3 +-
t/Catmandu-Fix-Bind-maybe.t | 3 +-
8 files changed, 57 insertions(+), 37 deletions(-)
diff --git a/lib/Catmandu/Fix/Bind.pm b/lib/Catmandu/Fix/Bind.pm
index bb9ecf1..54dbd66 100644
--- a/lib/Catmandu/Fix/Bind.pm
+++ b/lib/Catmandu/Fix/Bind.pm
@@ -6,7 +6,8 @@ use namespace::clean;
requires 'unit';
requires 'bind';
-has fixes => (is => 'rw', default => sub { [] });
+has return => (is => 'rw', default => sub { [0]});
+has fixes => (is => 'rw', default => sub { [] });
sub unit {
my ($self,$data) = @_;
@@ -18,11 +19,6 @@ sub bind {
return $code->($data);
}
-sub finally {
- my ($self,$data) = @_;
- $data;
-}
-
sub emit {
my ($self, $fixer, $label) = @_;
@@ -42,10 +38,6 @@ sub emit_bind {
my $bind_var = $fixer->capture($self);
my $unit = $fixer->generate_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) {
@@ -53,17 +45,22 @@ sub emit_bind {
my $code = $pair->[1];
my $code_var = $fixer->capture($code);
$perl .= "${unit} = ${bind_var}->bind(${unit}, sub {";
- $perl .= "${var} = shift;";
+ $perl .= "my ${var} = shift;";
$perl .= $code;
$perl .= "${var}";
$perl .= "},'$name',${code_var});"
}
- $perl .= "${unit} = ${bind_var}->finally(${unit});" if $self->can('finally');
-
my $reject = $fixer->capture($fixer->_reject);
$perl .= "return ${unit} if defined ${unit} && ${unit} == ${reject};";
+ if ($self->return) {
+ $perl .= "return ${unit};";
+ }
+ else {
+ $perl .= "return ${var};";
+ }
+
$perl;
}
@@ -104,7 +101,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 a 'do' statment:
+To wrap Fix functions, the Fix language has a 'do' statement:
do BIND
FIX1
@@ -112,9 +109,34 @@ To wrap Fix functions, the Fix language has a 'do' statment:
FIX3
end
-where BIND is a implementation of BIND and FIX1,...,FIXn are fix functions.
+where BIND is a implementation of Catmandu::Fix::Bind and FIX1,...,FIXn are Catmandu::Fix functions.
+
+In the example above the BIND will wrap FIX1, FIX2 and FIX3. BIND will first wrap the record data
+using its 'unit' method and send the data sequentially to each FIX which can make inline changes
+to the record data. In pseudo-code this will look like:
-In the example above the BIND will wrap FIX1, FIX2 and FIX3.
+ $bind_data = $bind->unit($data);
+ $bind_data = $bind->bind($bind_data, $fix1);
+ $bind_data = $bind->bind($bind_data, $fix2);
+ $bind_data = $bind->bind($bind_data, $fix3);
+ return $data;
+
+ An alternative form exists, 'doset' which will overwrite the record data with results of the last
+ fix.
+
+ doset BIND
+ FIX1
+ FIX2
+ FIX3
+ end
+
+Will result in a pseudo code like:
+
+ $bind_data = $bind->unit($data);
+ $bind_data = $bind->bind($bind_data, $fix1);
+ $bind_data = $bind->bind($bind_data, $fix2);
+ $bind_data = $bind->bind($bind_data, $fix3);
+ return $bind_data;
A Catmandu::Fix::Bind needs to implement two methods: 'unit' and 'bind'.
@@ -147,20 +169,9 @@ A trivial, but verbose, implementaion of 'bind' is:
$data;
}
-=head2 finally($data)
-
-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;
- }
-
=head1 REQUIREMENTS
-Bind mmodules are simplified implementations of Monads. They should answer the formal definition of Monads, codified
+Bind modules are simplified implementations of Monads. They should answer the formal definition of Monads, codified
in 3 monadic laws:
=head2 left unit: unit acts as a neutral element of bind
diff --git a/lib/Catmandu/Fix/Bind/benchmark.pm b/lib/Catmandu/Fix/Bind/benchmark.pm
index 017ecdb..c82539b 100644
--- a/lib/Catmandu/Fix/Bind/benchmark.pm
+++ b/lib/Catmandu/Fix/Bind/benchmark.pm
@@ -80,7 +80,7 @@ Required. The path of a file to which the benchmark statistics will be written.
=head1 AUTHOR
-hochsten L<hochsten at cpan.org>
+Patrick Hochstenbach <Patrick . Hochstenbach @ UGent . be >
=head1 SEE ALSO
diff --git a/lib/Catmandu/Fix/Bind/identity.pm b/lib/Catmandu/Fix/Bind/identity.pm
index 6d20101..e50e480 100644
--- a/lib/Catmandu/Fix/Bind/identity.pm
+++ b/lib/Catmandu/Fix/Bind/identity.pm
@@ -37,7 +37,7 @@ applies the bound fix functions to its input without any modification.
=head1 AUTHOR
-hochsten L<hochsten at cpan.org>
+Patrick Hochstenbach <Patrick . Hochstenbach @ UGent . be >
=head1 SEE ALSO
diff --git a/lib/Catmandu/Fix/Bind/maybe.pm b/lib/Catmandu/Fix/Bind/maybe.pm
index b8975ca..c324c9b 100644
--- a/lib/Catmandu/Fix/Bind/maybe.pm
+++ b/lib/Catmandu/Fix/Bind/maybe.pm
@@ -38,7 +38,7 @@ The maybe binder computes all the Fix function and ignores fixes that throw exce
=head1 AUTHOR
-hochsten L<hochsten at cpan.org>
+Patrick Hochstenbach <Patrick . Hochstenbach @ UGent . be >
=head1 SEE ALSO
diff --git a/lib/Catmandu/Fix/Parser.pm b/lib/Catmandu/Fix/Parser.pm
index 9480d68..0c768de 100644
--- a/lib/Catmandu/Fix/Parser.pm
+++ b/lib/Catmandu/Fix/Parser.pm
@@ -23,6 +23,7 @@ expression ::= old_if action => ::first
| unless action => ::first
| select action => ::first
| reject action => ::first
+ | doset action => ::first
| do action => ::first
| fix action => ::first
@@ -46,6 +47,8 @@ old_unless_condition ::= old_unless_name ('(') args (')') bless => OldCondition
condition ::= name ('(') args (')') bless => Condition
+doset ::= ('doset') bind fixes ('end') bless => DoSet
+
do ::= ('do') bind fixes ('end') bless => Do
bind ::= name ('(') args (')') bless => Bind
@@ -164,9 +167,18 @@ sub Catmandu::Fix::Parser::OldCondition::reify {
->new(map { $_->reify } @$args);
}
+sub Catmandu::Fix::Parser::DoSet::reify {
+ my $bind = $_[0]->[0]->reify;
+ my $do_fixes = $_[0]->[1];
+ $bind->return(1);
+ $bind->fixes([map { $_->reify } @$do_fixes]);
+ $bind;
+}
+
sub Catmandu::Fix::Parser::Do::reify {
my $bind = $_[0]->[0]->reify;
my $do_fixes = $_[0]->[1];
+ $bind->return(0);
$bind->fixes([map { $_->reify } @$do_fixes]);
$bind;
}
diff --git a/t/Catmandu-Fix-Bind-benchmark.t b/t/Catmandu-Fix-Bind-benchmark.t
index a670e51..ae0f3b3 100644
--- a/t/Catmandu-Fix-Bind-benchmark.t
+++ b/t/Catmandu-Fix-Bind-benchmark.t
@@ -22,7 +22,6 @@ is_deeply $monad->bind( $monad->unit({}), $f) , $f->({}) , "left unit monadic la
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)
@@ -103,4 +102,4 @@ $fixer = Catmandu::Fix->new(fixes => [$fixes]);
is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing nesting';
-done_testing 14;
\ No newline at end of file
+done_testing 13;
\ No newline at end of file
diff --git a/t/Catmandu-Fix-Bind-identity.t b/t/Catmandu-Fix-Bind-identity.t
index e60868b..7bb2d72 100644
--- a/t/Catmandu-Fix-Bind-identity.t
+++ b/t/Catmandu-Fix-Bind-identity.t
@@ -22,7 +22,6 @@ is_deeply $monad->bind( $monad->unit({}), $f) , $f->({}) , "left unit monadic la
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()
@@ -103,4 +102,4 @@ $fixer = Catmandu::Fix->new(fixes => [$fixes]);
is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing nesting';
-done_testing 14;
\ No newline at end of file
+done_testing 13;
\ No newline at end of file
diff --git a/t/Catmandu-Fix-Bind-maybe.t b/t/Catmandu-Fix-Bind-maybe.t
index c89a3d5..2d46d80 100644
--- a/t/Catmandu-Fix-Bind-maybe.t
+++ b/t/Catmandu-Fix-Bind-maybe.t
@@ -31,7 +31,6 @@ is_deeply $monad->bind( $monad->unit({}), $f) , $f->({}) , "left unit monadic la
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()
@@ -123,4 +122,4 @@ $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
+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