[Bps-public-commit] lcore branch, master, updated. 82525d2533a724a54e21f7329be7089b829755e9
clkao at bestpractical.com
clkao at bestpractical.com
Mon Aug 31 07:36:19 EDT 2009
The branch, master has been updated
via 82525d2533a724a54e21f7329be7089b829755e9 (commit)
via a1b7fb75abd7300e5f5506d8fdfd27cb006667d0 (commit)
via b4aba937c932c022ef0911bfb2fd3f526c775817 (commit)
via 3147d0ed72cac3ffa305f7da9912bfe9748f7d44 (commit)
via d0b6398a904e157441d277c158202deddbbc3817 (commit)
via 9e0073d8122b68ea1f60305e62871dc989b42499 (commit)
via 81df469369e64b1d00ce428c7e95a9887a5c76e5 (commit)
from 09f19d8f7c6939a41c3954bdc5b6b2aa4c816989 (commit)
Summary of changes:
Makefile.PL | 3 +-
lib/LCore/Expression/Lambda.pm | 2 +-
lib/LCore/Expression/TypedApplication.pm | 9 +----
lib/LCore/Function.pm | 13 +++++-
lib/LCore/Level1.pm | 7 +++
lib/LCore/Level2.pm | 65 ++++++++++++++++++++++++++++++
lib/LCore/Parameter.pm | 2 +-
t/byname.t | 2 +-
t/simple-coercion.t | 34 +++++++++++++++
t/type-lookup.t | 41 +++++++++++++++++++
t/typed-map.t | 2 +-
11 files changed, 166 insertions(+), 14 deletions(-)
create mode 100644 t/simple-coercion.t
create mode 100644 t/type-lookup.t
- Log -----------------------------------------------------------------
commit 81df469369e64b1d00ce428c7e95a9887a5c76e5
Author: Chia-liang Kao <clkao at clkao.org>
Date: Mon Aug 24 12:52:12 2009 +0100
requires moosex::classattribute.
diff --git a/Makefile.PL b/Makefile.PL
index 680438b..552e742 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -10,7 +10,8 @@ test_requires (Test::More => 0,
requires ( Data::SExpression => 0,
Moose => 0,
- MooseX::Traits => 0.06
+ MooseX::Traits => 0.06,
+ MooseX::ClassAttribute => 0,
);
commit 9e0073d8122b68ea1f60305e62871dc989b42499
Author: Chia-liang Kao <clkao at clkao.org>
Date: Mon Aug 31 15:51:24 2009 +0800
make LCore::Parameter always hold moose::meta::typeconstraint object.
diff --git a/lib/LCore/Expression/Lambda.pm b/lib/LCore/Expression/Lambda.pm
index 47c9bd0..264d3cc 100644
--- a/lib/LCore/Expression/Lambda.pm
+++ b/lib/LCore/Expression/Lambda.pm
@@ -18,7 +18,7 @@ sub analyze {
my $lambda_body = $env->analyze($body);
- $params = [ map { LCore::Parameter->new( name => "$_" ) } @$params ];
+ $params = [ map { LCore::Parameter->new( { name => "$_" } ) } @$params ];
my $function = LCore::Procedure->new( { env => $env,
body => $lambda_body,
diff --git a/lib/LCore/Expression/TypedApplication.pm b/lib/LCore/Expression/TypedApplication.pm
index 248d0f0..1eed41c 100644
--- a/lib/LCore/Expression/TypedApplication.pm
+++ b/lib/LCore/Expression/TypedApplication.pm
@@ -25,10 +25,6 @@ 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) = @_;
@@ -43,9 +39,6 @@ before 'mk_expression' => sub {
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);
}
@@ -54,7 +47,7 @@ before 'mk_expression' => sub {
sub _get_arg_return_type {
my ($self, $env, $arg) = @_;
return unless UNIVERSAL::can($arg, 'get_return_type');
- return $arg->get_return_type($env);
+ return Moose::Util::TypeConstraints::find_or_create_isa_type_constraint( $arg->get_return_type($env) );
}
no Moose;
diff --git a/lib/LCore/Parameter.pm b/lib/LCore/Parameter.pm
index ac9f76d..2d4d4fa 100644
--- a/lib/LCore/Parameter.pm
+++ b/lib/LCore/Parameter.pm
@@ -1,8 +1,19 @@
package LCore::Parameter;
use Moose;
+use Moose::Util::TypeConstraints qw(find_type_constraint type);
+
+type 'Function';
has name => (is => "ro", isa => "Str");
-has type => (is => "ro", isa => "Str");
+has type => (is => "ro", isa => "Moose::Meta::TypeConstraint");
+
+sub BUILDARGS {
+ my ($self, $args) = @_;
+ if ($args->{type} && !ref($args->{type})) {
+ $args->{type} = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($args->{type})
+ }
+ return $args;
+}
use overload (
fallback => 1,
diff --git a/t/byname.t b/t/byname.t
index ef9902f..f0a55aa 100644
--- a/t/byname.t
+++ b/t/byname.t
@@ -10,7 +10,7 @@ $l->env->set_symbol('/' => LCore::Primitive->new
( body => sub {
return $_[0] / $_[1];
},
- parameters => [ map { LCore::Parameter->new( name => $_, type => 'Num' ) } ('x', 'y') ],
+ parameters => [ map { LCore::Parameter->new({ name => $_, type => 'Num' }) } ('x', 'y') ],
));
is_deeply($l->analyze_it(q{(/ 5 2)})->($l->env), 2.5);
diff --git a/t/typed-map.t b/t/typed-map.t
index 8faff71..ee5f114 100644
--- a/t/typed-map.t
+++ b/t/typed-map.t
@@ -17,7 +17,7 @@ $l->env->set_symbol('*' => LCore::Primitive->new
my $proc = LCore::Procedure->new( { env => $l->env,
body => $l->analyze_it(q{(* n n)}),
- parameters => ['n'] } );
+ parameters => [LCore::Parameter->new({ name => 'n', type => 'Num' } )] } );
is($proc->return_type, 'Num', "return type derived");
commit d0b6398a904e157441d277c158202deddbbc3817
Author: Chia-liang Kao <clkao at clkao.org>
Date: Mon Aug 31 16:27:44 2009 +0800
use coercion for lcore::type.
diff --git a/lib/LCore/Function.pm b/lib/LCore/Function.pm
index 794fd15..5835a71 100644
--- a/lib/LCore/Function.pm
+++ b/lib/LCore/Function.pm
@@ -1,8 +1,19 @@
package LCore::Function;
use Moose::Role;
+use Moose::Util::TypeConstraints;
+
+type 'Function';
+
+subtype 'LCore::Type'
+ => as 'Object'
+ => where { $_->isa('Moose::Meta::TypeConstraint') };
+
+coerce 'LCore::Type'
+ => from 'Str'
+ => via { Moose::Util::TypeConstraints::find_or_create_isa_type_constraint( $_ ) };
has parameters => (is => "ro", isa => "ArrayRef");
-has return_type => (is => "rw", isa => "Str");
+has return_type => (is => "rw", isa => "LCore::Type", coerce => 1);
has lazy => (is => "ro", isa => "Bool", default => 1);
has slurpy => (is => "ro", isa => "Bool", default => 0);
diff --git a/lib/LCore/Parameter.pm b/lib/LCore/Parameter.pm
index 2d4d4fa..b7ba5aa 100644
--- a/lib/LCore/Parameter.pm
+++ b/lib/LCore/Parameter.pm
@@ -1,19 +1,8 @@
package LCore::Parameter;
use Moose;
-use Moose::Util::TypeConstraints qw(find_type_constraint type);
-
-type 'Function';
has name => (is => "ro", isa => "Str");
-has type => (is => "ro", isa => "Moose::Meta::TypeConstraint");
-
-sub BUILDARGS {
- my ($self, $args) = @_;
- if ($args->{type} && !ref($args->{type})) {
- $args->{type} = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($args->{type})
- }
- return $args;
-}
+has type => (is => "ro", isa => "LCore::Type", coerce => 1);
use overload (
fallback => 1,
commit 3147d0ed72cac3ffa305f7da9912bfe9748f7d44
Author: Chia-liang Kao <clkao at clkao.org>
Date: Mon Aug 31 17:12:53 2009 +0800
add 'not' primitive.
diff --git a/lib/LCore/Level1.pm b/lib/LCore/Level1.pm
index 7747a6b..2061068 100644
--- a/lib/LCore/Level1.pm
+++ b/lib/LCore/Level1.pm
@@ -75,6 +75,13 @@ sub BUILD {
parameters => [ LCore::Parameter->new({ name => 'conditions', type => 'ArrayRef[Bool]' })],
return_type => 'Bool'));
+ $self->set_symbol('not' => LCore::Primitive->new
+ ( lazy => 0,
+ body => sub {
+ return !$_[0];
+ },
+ parameters => [ LCore::Parameter->new({ name => 'condition', type => 'Bool' })],
+ return_type => 'Bool' ));
}
__PACKAGE__->meta->make_immutable;
commit b4aba937c932c022ef0911bfb2fd3f526c775817
Author: Chia-liang Kao <clkao at clkao.org>
Date: Mon Aug 31 17:13:50 2009 +0800
basic type library lookup facility.
diff --git a/lib/LCore/Level2.pm b/lib/LCore/Level2.pm
index cd92a02..275e7f2 100644
--- a/lib/LCore/Level2.pm
+++ b/lib/LCore/Level2.pm
@@ -8,6 +8,62 @@ use LCore::Expression::Lambda;
extends 'LCore::Level1';
+sub find_functions_by_type {
+ my ($self, $expected_param_types, $expected_return_type) = @_;
+ my $result = {};
+ my $func = $self->all_functions;
+ while (my ($name, $func) = each %$func) {
+ next unless $func->parameters && $func->return_type;
+ $func->return_type->is_a_type_of( $expected_return_type ) or next;
+ if (ref $expected_param_types eq 'ARRAY') { # positional match
+ my $i = 0;
+ next if $#{$expected_param_types} > $#{$func->parameters};
+ my $found = 1;
+ for (@$expected_param_types) {
+ $func->parameters->[$i]->type->is_a_type_of( $_ ) or $found = 0;
+ }
+ next unless $found;
+ }
+ else { # match any param
+ my $found = 0;
+ for (@{$func->parameters}) {
+ $found = 1 if $_->type->is_a_type_of( $expected_param_types );
+ # match for parameterized type of ArrayRef
+ if ($_->type->isa('Moose::Meta::TypeConstraint::Parameterized')) {
+ $found = 1 if
+ $_->type->parent->name eq 'ArrayRef' &&
+ $_->type->type_parameter->is_a_type_of( $expected_param_types );
+ }
+ }
+ next unless $found;
+ }
+ $result->{$name} = $func;
+ }
+ return $result;
+}
+
+sub all_functions {
+ my ($self) = @_;
+ my $result = {};
+ for ($self->all_symbols) {
+ my $func = $self->get_value($_);
+ next unless $func->does('LCore::Function');
+ $result->{$_} = $func;
+ }
+ return $result;
+}
+
+sub all_symbols {
+ my ($self) = @_;
+ my %name;
+ my $env = $self;
+ while ($env) {
+ $name{$_} = 1 for keys %{$env->symbols};
+ $env = $env->parent;
+ }
+ return keys %name;
+}
+
sub typed_expression {
my ($self, $expression_class, $specialized) = @_;
my $class = "LCore::Expression::".$expression_class;
diff --git a/t/type-lookup.t b/t/type-lookup.t
new file mode 100644
index 0000000..7195048
--- /dev/null
+++ b/t/type-lookup.t
@@ -0,0 +1,41 @@
+#!/usr/bin/perl -w
+
+use Test::More tests => 4;
+use LCore::Level2;
+use LCore::Parameter;
+use LCore::Procedure;
+use Test::Exception;
+my $l = LCore->new( env => LCore::Level2->new );
+
+$l->env->set_symbol($_ => LCore::Primitive->new
+ ( body => sub {
+ die 'stub only';
+ },
+ parameters => [ LCore::Parameter->new({ name => 'a', type => 'Str' }),
+ LCore::Parameter->new({ name => 'b', type => 'Str' }) ],
+ return_type => 'Bool',
+ ))
+ for qw( str.is str.!is str.contains str.!contains str.startswith str.endswith );
+
+$l->env->set_symbol($_ => LCore::Primitive->new
+ ( body => sub {
+ die 'stub only';
+ },
+ parameters => [ LCore::Parameter->new({ name => 'a', type => 'Str' }),
+ LCore::Parameter->new({ name => 'b', type => 'Num' }) ],
+ return_type => 'Bool',
+ ))
+ for qw( str.isnum );
+
+is_deeply( [sort keys %{ $l->env->find_functions_by_type(['Str'], 'Bool') }],
+ [qw(str.!contains str.!is str.contains str.endswith str.is str.isnum str.startswith)] );
+
+is_deeply( [sort keys %{ $l->env->find_functions_by_type('Str', 'Bool') }],
+ [qw(str.!contains str.!is str.contains str.endswith str.is str.isnum str.startswith)] );
+
+is_deeply( [sort keys %{ $l->env->find_functions_by_type(['Bool'], 'Bool')}],
+ [qw(not)] );
+
+is_deeply( [sort keys %{ $l->env->find_functions_by_type('Bool', 'Bool')}],
+ [qw(and not or)] );
+
commit a1b7fb75abd7300e5f5506d8fdfd27cb006667d0
Author: Chia-liang Kao <clkao at clkao.org>
Date: Mon Aug 31 17:15:00 2009 +0800
test for simple coercion of self-evaluating expressions.
diff --git a/t/simple-coercion.t b/t/simple-coercion.t
new file mode 100644
index 0000000..4bbc98b
--- /dev/null
+++ b/t/simple-coercion.t
@@ -0,0 +1,34 @@
+#!/usr/bin/perl -w
+use Test::More tests => 2;
+use LCore::Level2;
+use LCore::Procedure;
+
+my $l = LCore->new( env => LCore::Level2->new );
+my $env = $l->env;
+$env->set_symbol('Str.Eq' => LCore::Primitive->new
+ ( body => sub {
+ return $_[0] eq $_[1];
+ },
+ parameters => [ LCore::Parameter->new({ name => 'left', type => 'Str' }),
+ LCore::Parameter->new({ name => 'right', type => 'Str' })],
+ return_type => 'Bool'
+ ));
+
+$env->set_symbol('bar' => LCore::Primitive->new
+ ( body => sub { 'foo' },
+ return_type => 'Str' ));
+
+
+is($l->analyze_it(q{(Str.Eq "foo" (bar))})->($env), 1);
+
+is($l->analyze_it(q{(Str.Eq "foo" "1")})->($env), '');
+
+
+$env->set_symbol('Str.Eq' => LCore::Primitive->new
+ ( body => sub {
+ return $_[0] eq $_[1];
+ },
+ parameters => [ LCore::Parameter->new({ name => 'left', type => 'Str' }),
+ LCore::Parameter->new({ name => 'right', type => 'Str' })],
+ return_type => 'Bool'
+ ));
commit 82525d2533a724a54e21f7329be7089b829755e9
Author: Chia-liang Kao <clkao at clkao.org>
Date: Mon Aug 31 19:32:29 2009 +0800
cleanup find_functions_by_type.
diff --git a/lib/LCore/Level2.pm b/lib/LCore/Level2.pm
index 275e7f2..3d0ff13 100644
--- a/lib/LCore/Level2.pm
+++ b/lib/LCore/Level2.pm
@@ -8,34 +8,43 @@ use LCore::Expression::Lambda;
extends 'LCore::Level1';
+sub _function_matches_types {
+ my ($self, $func, $types, $return_type, $strict) = @_;
+ return unless $func->return_type->is_a_type_of( $return_type );
+ return if $#{$types} > $#{$func->parameters};
+ return if $strict && $#{$types} < $#{$func->parameters};
+
+ my $i = 0;
+ for (@$types) {
+ $func->parameters->[$i]->type->is_a_type_of( $_ ) or return;
+ }
+ return 1;
+}
+
+sub _function_matches_any_type {
+ my ($self, $func, $type, $return_type) = @_;
+ for (@{$func->parameters}) {
+ return 1 if $_->type->is_a_type_of( $type );
+ # match for parameterized type of ArrayRef
+ if ($_->type->isa('Moose::Meta::TypeConstraint::Parameterized')) {
+ return 1 if $_->type->parent->name eq 'ArrayRef' &&
+ $_->type->type_parameter->is_a_type_of( $type );
+ }
+ }
+ return 0;
+}
+
sub find_functions_by_type {
- my ($self, $expected_param_types, $expected_return_type) = @_;
+ my ($self, $param_types, $return_type) = @_;
my $result = {};
my $func = $self->all_functions;
while (my ($name, $func) = each %$func) {
next unless $func->parameters && $func->return_type;
- $func->return_type->is_a_type_of( $expected_return_type ) or next;
- if (ref $expected_param_types eq 'ARRAY') { # positional match
- my $i = 0;
- next if $#{$expected_param_types} > $#{$func->parameters};
- my $found = 1;
- for (@$expected_param_types) {
- $func->parameters->[$i]->type->is_a_type_of( $_ ) or $found = 0;
- }
- next unless $found;
+ if (ref $param_types eq 'ARRAY') { # positional match
+ next unless $self->_function_matches_types($func, $param_types, $return_type);
}
else { # match any param
- my $found = 0;
- for (@{$func->parameters}) {
- $found = 1 if $_->type->is_a_type_of( $expected_param_types );
- # match for parameterized type of ArrayRef
- if ($_->type->isa('Moose::Meta::TypeConstraint::Parameterized')) {
- $found = 1 if
- $_->type->parent->name eq 'ArrayRef' &&
- $_->type->type_parameter->is_a_type_of( $expected_param_types );
- }
- }
- next unless $found;
+ next unless $self->_function_matches_any_type($func, $param_types, $return_type);
}
$result->{$name} = $func;
}
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list