[Bps-public-commit] lcore branch, master, updated. 13878590033f020e3fd8ffe0d65ec0b025bdab08
clkao at bestpractical.com
clkao at bestpractical.com
Wed Aug 19 13:49:43 EDT 2009
The branch, master has been updated
via 13878590033f020e3fd8ffe0d65ec0b025bdab08 (commit)
via 8e6db5348b5294ba9b1b9d01ce63cc2f86443e9c (commit)
via afffc6b943a733092329cdc642b74b5dce3840f7 (commit)
via bc750633dab6bfe784ecabd1c178c4e78a84c1e5 (commit)
from a755bf2b5fe27bf13fdc77bec0d6d9a3418afdb6 (commit)
Summary of changes:
lib/LCore/Expression/Application.pm | 5 ++-
lib/LCore/Expression/TypedApplication.pm | 59 ++++++++++++++++++++++++------
lib/LCore/Function.pm | 1 +
lib/LCore/Level1.pm | 31 +++++++++++-----
lib/LCore/TypedExpression.pm | 2 +-
t/typed-map.t | 36 ++++++++++++++++++
6 files changed, 110 insertions(+), 24 deletions(-)
create mode 100644 t/typed-map.t
- Log -----------------------------------------------------------------
commit bc750633dab6bfe784ecabd1c178c4e78a84c1e5
Author: Chia-liang Kao <clkao at clkao.org>
Date: Tue Aug 18 20:06:58 2009 +0200
tests for typed-map and slurpy parameters.
diff --git a/lib/LCore/Expression/Application.pm b/lib/LCore/Expression/Application.pm
index 1f6176d..6882583 100644
--- a/lib/LCore/Expression/Application.pm
+++ b/lib/LCore/Expression/Application.pm
@@ -28,7 +28,8 @@ sub analyze {
}
sub get_operands {
- my ($class, $proc, $operands) = @_;
+ my ($class, $env, $proc, $operands) = @_;
+
return @$operands if ref($operands) eq 'ARRAY';
my $params = $proc->parameters or die "params by name unavailable for functions not defined with params: $proc";
@@ -44,7 +45,7 @@ sub mk_expression {
my $env = shift;
my $o = $operator->($env) or die "can't find operator";
- my @args = $class->get_operands($o, $operands);
+ my @args = $class->get_operands($env, $o, $operands);
my @a = $o->lazy
? map { ref $_ ? LCore::Thunk->new( env => $env, delayed => $_ ): $_ } @args
diff --git a/lib/LCore/Expression/TypedApplication.pm b/lib/LCore/Expression/TypedApplication.pm
index 493563b..2a62943 100644
--- a/lib/LCore/Expression/TypedApplication.pm
+++ b/lib/LCore/Expression/TypedApplication.pm
@@ -2,12 +2,37 @@ package LCore::Expression::TypedApplication;
use Moose::Role;
with 'LCore::TypedExpression';
+around 'get_operands' => sub {
+ my ($next, $self, $env, $proc, $operands) = @_;
+ my @args = $self->$next($env, $proc, $operands);
+
+ if ($proc->parameters && $proc->slurpy) {
+ # auto arraify
+ my @params = @{$proc->parameters};
+ die 'slurpy arg should be arrayref'
+ unless $params[-1]->type =~ m/^ArrayRef/;
+ if ($#args == $#params) {
+ return @args unless UNIVERSAL::can($args[-1], 'get_return_type');
+ if (my $incoming = $args[-1]->get_return_type($env)) {
+ return @args if $incoming =~ m/^ArrayRef/;
+ }
+ }
+ if ($#args >= $#params) {
+ my @arraify = @args[$#params..$#args];
+ my $x = sub { my $env = shift; [map { $_->($env) } @arraify] };
+ splice(@args, $#params);
+ push @args, $x;
+ }
+ }
+ return @args;
+};
+
before 'mk_expression' => sub {
my ($self, $env, $operator, $operands) = @_;
my ($func, $name) = $self->get_procedure($env, $operator) or return;
- my @args = $self->get_operands($func, $operands);
+ my @args = $self->get_operands($env, $func, $operands);
if (my $params = $func->parameters) {
die "argument number mismatch for $name" if $#{$params} ne $#args;
diff --git a/lib/LCore/Function.pm b/lib/LCore/Function.pm
index db1d8bf..794fd15 100644
--- a/lib/LCore/Function.pm
+++ b/lib/LCore/Function.pm
@@ -4,6 +4,7 @@ use Moose::Role;
has parameters => (is => "ro", isa => "ArrayRef");
has return_type => (is => "rw", isa => "Str");
has lazy => (is => "ro", isa => "Bool", default => 1);
+has slurpy => (is => "ro", isa => "Bool", default => 0);
requires 'apply';
diff --git a/lib/LCore/Level1.pm b/lib/LCore/Level1.pm
index f752951..5216a5f 100644
--- a/lib/LCore/Level1.pm
+++ b/lib/LCore/Level1.pm
@@ -31,36 +31,47 @@ sub BUILD {
$self->set_symbol('list' => LCore::Primitive->new
( body => sub {
return [@_];
- }));
+ },
+ return_type => 'ArrayRef',
+ ));
# (a -> b) -> [a] -> [b]
$self->set_symbol('map' => LCore::Primitive->new
- ( lazy => 0,
+ ( lazy => 0, # this is one level force, for the list
+ slurpy => 1,
body => sub {
my ($func, $list) = @_;
return [map {$func->apply($_)} @$list];
- }));
+ },
+ parameters => [ LCore::Parameter->new({ name => 'func', type => 'Function' }),
+ LCore::Parameter->new({ name => 'items', type => 'ArrayRef' }) ],
+ return_type => 'ArrayRef',
+ ));
$self->set_symbol('and' => LCore::Primitive->new
( body => sub {
my $i = 0;
- for (@_) {
+ for (@{$_[0]}) {
if (!$_) {
return 0;
}
}
return 1;
- }));
+ },
+ parameters => [ LCore::Parameter->new({ name => 'conditions', type => 'ArrayRef[Bool]' })],
+ return_type => 'Bool' ));
$self->set_symbol('or' => LCore::Primitive->new
( body => sub {
- for (@_) {
+ for (@{$_[0]}) {
if ($_) {
return 1;
}
}
return 0;
- }));
+ },
+ parameters => [ LCore::Parameter->new({ name => 'conditions', type => 'ArrayRef[Bool]' })],
+ return_type => 'Bool'));
}
diff --git a/lib/LCore/TypedExpression.pm b/lib/LCore/TypedExpression.pm
index 558cc95..d274084 100644
--- a/lib/LCore/TypedExpression.pm
+++ b/lib/LCore/TypedExpression.pm
@@ -7,7 +7,7 @@ sub get_procedure {
if (ref($expression) eq 'LCore::Expression::Variable') {
my $name = $expression->name;
- my $func = $env->get_symbol($name)
+ my $func = $env->get_value($name)
or die "'$name' not defined";
return ($func, $name);
}
diff --git a/t/typed-map.t b/t/typed-map.t
new file mode 100644
index 0000000..8faff71
--- /dev/null
+++ b/t/typed-map.t
@@ -0,0 +1,36 @@
+#!/usr/bin/perl -w
+use Test::More tests => 5;
+use LCore::Level2;
+use LCore::Parameter;
+use Data::Dumper;$Data::Dumper::Deparse=1;
+use LCore::Procedure;
+use Test::Exception;
+my $l = LCore->new( env => LCore::Level2->new );
+$l->env->set_symbol('*' => LCore::Primitive->new
+ ( body => sub {
+ return $_[0] * $_[1];
+ },
+ parameters => [ LCore::Parameter->new({ name => 'a', type => 'Num' }),
+ LCore::Parameter->new({ name => 'b', type => 'Num' }) ],
+ return_type => 'Num',
+ ));
+
+my $proc = LCore::Procedure->new( { env => $l->env,
+ body => $l->analyze_it(q{(* n n)}),
+ parameters => ['n'] } );
+
+is($proc->return_type, 'Num', "return type derived");
+
+$l->env->set_symbol('square' => $proc);
+
+my $proc2 = LCore::Procedure->new( { env => $l->env,
+ body => $l->analyze_it(q{(map square (list 5 (* 1 6) 7))}),
+ parameters => [] } );
+
+like $proc2->return_type, qr/^ArrayRef/;
+
+is_deeply($proc2->apply(), [25, 36, 49]);
+
+is_deeply($l->analyze_it(q{(map square 5 6 7))})->($l->env), [25, 36, 49]);
+
+is_deeply($l->analyze_it(q{(map square 5))})->($l->env), [25]);
commit afffc6b943a733092329cdc642b74b5dce3840f7
Author: Chia-liang Kao <clkao at clkao.org>
Date: Tue Aug 18 20:08:34 2009 +0200
make and/or eager and slurpy
diff --git a/lib/LCore/Level1.pm b/lib/LCore/Level1.pm
index 5216a5f..7747a6b 100644
--- a/lib/LCore/Level1.pm
+++ b/lib/LCore/Level1.pm
@@ -49,7 +49,8 @@ sub BUILD {
));
$self->set_symbol('and' => LCore::Primitive->new
- ( body => sub {
+ ( lazy => 0, slurpy => 1,
+ body => sub {
my $i = 0;
for (@{$_[0]}) {
if (!$_) {
@@ -62,7 +63,8 @@ sub BUILD {
return_type => 'Bool' ));
$self->set_symbol('or' => LCore::Primitive->new
- ( body => sub {
+ ( lazy => 0, slurpy => 1,
+ body => sub {
for (@{$_[0]}) {
if ($_) {
return 1;
commit 8e6db5348b5294ba9b1b9d01ce63cc2f86443e9c
Author: Chia-liang Kao <clkao at clkao.org>
Date: Tue Aug 18 21:39:08 2009 +0200
use Moose::Util::TypeConstraints for type checking during application
diff --git a/lib/LCore/Expression/TypedApplication.pm b/lib/LCore/Expression/TypedApplication.pm
index 2a62943..9c863f0 100644
--- a/lib/LCore/Expression/TypedApplication.pm
+++ b/lib/LCore/Expression/TypedApplication.pm
@@ -27,6 +27,10 @@ around 'get_operands' => sub {
return @args;
};
+use Moose::Util::TypeConstraints qw(type find_type_constraint);
+
+type 'Function';
+
before 'mk_expression' => sub {
my ($self, $env, $operator, $operands) = @_;
@@ -40,8 +44,12 @@ before 'mk_expression' => sub {
my $expected = $params->[$_]->type or next;
next unless UNIVERSAL::can($args[$_], 'get_return_type');
if (my $incoming = $args[$_]->get_return_type($env)) {
+ ($incoming, $expected) = map { find_type_constraint($_) || $_ } ($incoming, $expected);
+ warn "not registered $incoming" unless ref($incoming);
+ warn "not registered $expected" unless ref($expected);
die "type mismatch for '$name' parameters @{[ 1 + $_ ]}: expecting $expected, got $incoming"
- if $incoming ne $expected;
+ unless $incoming->is_a_type_of($expected);
+
}
}
}
commit 13878590033f020e3fd8ffe0d65ec0b025bdab08
Author: Chia-liang Kao <clkao at clkao.org>
Date: Tue Aug 18 22:10:20 2009 +0200
minor cleanup.
diff --git a/lib/LCore/Expression/TypedApplication.pm b/lib/LCore/Expression/TypedApplication.pm
index 9c863f0..248d0f0 100644
--- a/lib/LCore/Expression/TypedApplication.pm
+++ b/lib/LCore/Expression/TypedApplication.pm
@@ -12,10 +12,8 @@ around 'get_operands' => sub {
die 'slurpy arg should be arrayref'
unless $params[-1]->type =~ m/^ArrayRef/;
if ($#args == $#params) {
- return @args unless UNIVERSAL::can($args[-1], 'get_return_type');
- if (my $incoming = $args[-1]->get_return_type($env)) {
- return @args if $incoming =~ m/^ArrayRef/;
- }
+ my $incoming = $self->_get_arg_return_type($env, $args[-1]);
+ return @args if !$incoming || $incoming =~ m/^ArrayRef/;
}
if ($#args >= $#params) {
my @arraify = @args[$#params..$#args];
@@ -38,22 +36,26 @@ before 'mk_expression' => sub {
my @args = $self->get_operands($env, $func, $operands);
- if (my $params = $func->parameters) {
- die "argument number mismatch for $name" if $#{$params} ne $#args;
- for (0..$#args) {
- my $expected = $params->[$_]->type or next;
- next unless UNIVERSAL::can($args[$_], 'get_return_type');
- if (my $incoming = $args[$_]->get_return_type($env)) {
- ($incoming, $expected) = map { find_type_constraint($_) || $_ } ($incoming, $expected);
- warn "not registered $incoming" unless ref($incoming);
- warn "not registered $expected" unless ref($expected);
- die "type mismatch for '$name' parameters @{[ 1 + $_ ]}: expecting $expected, got $incoming"
- unless $incoming->is_a_type_of($expected);
-
- }
- }
+ my $params = $func->parameters or return;
+
+ die "argument number mismatch for $name" if $#{$params} ne $#args;
+ for (0..$#args) {
+ my $expected = $params->[$_]->type or next;
+ my $incoming = $self->_get_arg_return_type($env, $args[$_]) or next;
+
+ ($incoming, $expected) = map { find_type_constraint($_) || $_ } ($incoming, $expected);
+ warn "not registered $incoming" unless ref($incoming);
+ warn "not registered $expected" unless ref($expected);
+ die "type mismatch for '$name' parameters @{[ 1 + $_ ]}: expecting $expected, got $incoming"
+ unless $incoming->is_a_type_of($expected);
}
};
+sub _get_arg_return_type {
+ my ($self, $env, $arg) = @_;
+ return unless UNIVERSAL::can($arg, 'get_return_type');
+ return $arg->get_return_type($env);
+}
+
no Moose;
1;
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list