[Bps-public-commit] r12586 - in pie/trunk: . lib lib/PIE t
jesse at bestpractical.com
jesse at bestpractical.com
Wed May 21 02:35:11 EDT 2008
Author: jesse
Date: Wed May 21 02:35:11 2008
New Revision: 12586
Added:
pie/trunk/doc/
pie/trunk/doc/Pinglin Instruction Environment
pie/trunk/doc/yapperl.txt
pie/trunk/lib/
pie/trunk/lib/PIE/
pie/trunk/lib/PIE.pm
pie/trunk/lib/PIE/Builder.pm
pie/trunk/lib/PIE/Evaluatable.pm
pie/trunk/lib/PIE/Evaluator.pm
pie/trunk/lib/PIE/EvaluatorResult.pm
pie/trunk/lib/PIE/Expression.pm
pie/trunk/lib/PIE/Lambda.pm
pie/trunk/t/
pie/trunk/t/01basic.t
Modified:
pie/trunk/ (props changed)
Log:
- Merge //mirror/bps-public/pie/branches/import to //mirror/bps-public/pie/trunk
Added: pie/trunk/doc/Pinglin Instruction Environment
==============================================================================
--- (empty file)
+++ pie/trunk/doc/Pinglin Instruction Environment Wed May 21 02:35:11 2008
@@ -0,0 +1,461 @@
+
+=begin trivial problem statement
+
+# It's as easy as PIE
+- (progn list)
+- (let ((x ...) ( y ...)) (exp....))
+- (if (cond...) on_true on_false)
+- (match a b)
+- defun
+
+sub foo(Str $var) {
+ if ($var ~~ /software/) {
+ return 'hate';
+ }
+ else {
+ return 'love';
+ }
+}
+
+(defun foo (var)
+ (if (regexp-match (ticket-title! var) "/software")
+ "hate"
+ "love"
+ ))
+
+- defun
+ name: foo
+ args:
+ - var
+ expression:
+ if:
+ cond:
+ regexp-match:
+ - args:
+ - var
+ - 'software'
+ on_true: "hate"
+ on_false: "love"
+
+=cut
+
+# naive implementation
+
+
+
+package PIE::Evaluatable;
+use Moose::Role;
+
+requires 'evaluate';
+
+package PIE::Lambda;
+use Moose; use MooseX::Params::Validate;
+with 'PIE::Evaluatable';
+
+has nodes => (
+ is => 'rw',
+ isa => 'ArrayRef',
+);
+
+has bindings => (
+ is => 'rw',
+ isa => 'ArrayRef[Str]');
+
+
+
+sub evaluate {
+ my $self = shift;
+ my $evaluator = shift;
+# my %args = validate(@_, { context => 1});
+ foreach my $node (@{$self->nodes}) {
+ $evaluator->run($node);
+
+ }
+
+}
+
+
+package PIE::Expression;
+use Moose;
+
+with 'PIE::Evaluatable';
+
+has elements => (
+ is => 'ro',
+ isa => 'ArrayRef');
+
+# (foo bar (orz 1 ))
+# === (eval 'foo bar (orz 1))
+# === (apply foo ((bar (orz 1))
+
+
+
+sub evaluate {
+ my ($self, $ev) = @_;
+ my $func = $self->elements->[0];
+ my @exp = @{ $self->elements }[1..$#{ $self->elements }];
+ my $lambda = $ev->resolve_name($func);
+ return $ev->apply_script($lambda, @exp);
+}
+
+package PIE::Expression::True;
+use Moose;
+
+extends 'PIE::Expression';
+
+sub evaluate {1}
+
+package PIE::Expression::False;
+use Moose;
+extends 'PIE::Expression::True';
+
+sub evaluate {
+ my $self = shift;
+ return ! $self->SUPER::evaluate();
+
+}
+
+package PIE::Expression::Loop;
+use Moose;
+extends 'PIE::Expression';
+
+has items => ( is => 'rw', isa => 'ArrayRef[PIE::Evaluatable]');
+has block => ( is => 'rw', isa => 'PIE::Evaluatable');
+
+sub evaluate {
+ my $self = shift;
+
+}
+
+
+
+
+
+package PIE::Expression::IfThen;
+use Moose;
+extends 'PIE::Expression';
+
+
+has condition => (
+ is => 'rw',
+ does => 'PIE::Evaluatable');
+
+has if_true => (
+ is => 'rw',
+ does => 'PIE::Evaluatable');
+
+has if_false => (
+ is => 'rw',
+ does => 'PIE::Evaluatable');
+
+
+sub arguments { return qw(condition if_true if_false)}
+
+
+sub evaluate {
+ my $self = shift;
+ my $evaluator = shift;
+ $evaluator->run($self->condition);
+
+
+ if ($evaluator->result->value) {
+
+ $evaluator->run($self->if_true);
+ return $evaluator->result->value;
+ } else {
+ $evaluator->run($self->if_false);
+ return $evaluator->result->value;
+ }
+}
+
+
+package PIE::Expression::String;
+use Moose;
+extends 'PIE::Expression';
+
+has value => (
+ is => 'rw',
+ isa => 'Str | Undef');
+
+
+sub evaluate {
+ my $self = shift;
+ return $self->value;
+
+}
+
+package PIE::Expression::Symbol;
+use Moose;
+extends 'PIE::Expression';
+
+has symbol => (
+ is => 'rw',
+ isa => 'Str');
+
+
+sub evaluate {
+ my ($self, $ev) = @_;
+ my $result = $ev->get_named($self->symbol);
+ warn $self->symbol;
+ warn $result;
+ return $result->isa('PIE::Expression') ? $ev->run($result) : $result; # XXX: figure out evaluation order here
+}
+
+package PIE::Evaluator;
+use Moose;
+use MooseX::AttributeHelpers;
+
+has result => (
+ is => 'ro',
+ isa => 'PIE::EvaluatorResult',
+ default => sub { return PIE::EvaluatorResult->new()}
+ );
+
+has named => (
+ metaclass => 'Collection::Hash',
+ is => 'rw',
+ default => sub { {} },
+ isa => 'HashRef',
+ provides => {
+ get => 'get_named',
+ set => 'set_named',
+ });
+
+sub run {
+ my $self = shift;
+ my $expression = shift;
+ eval {
+ my $ret = $expression->evaluate($self);
+ $self->result->value($ret) ; # XXX TODO - we should be separating out success and value
+ $self->result->success(1);
+ };
+ if (my $err = $@) {
+ die $err; # for now
+
+ $self->result->success(0);
+ $self->result->error($err);
+ }
+
+ return 1;
+}
+
+sub resolve_name {
+ my ($self, $name) = @_;
+ $self->get_named($name);
+}
+
+
+sub apply_script {
+ my ($self, $lambda, @exp) = @_;
+ if (ref($lambda) eq 'CODE') {
+ $lambda->(map {$self->run($_); $self->result->value } @exp);
+ }
+ elsif ($lambda->isa("PIE::Lambda")) {
+ my $bindings = $lambda->bindings;
+ die "unmatched number of arguments" unless $#{$bindings} == $#exp;
+ # XXX: cleanup, unmask, etc
+ $self->set_named( $bindings->[$_] => $exp[$_] ) for 0.. $#exp;
+ $lambda->evaluate($self);
+ }
+ else {
+ die 'wtf';
+ }
+}
+
+
+package PIE::EvaluatorResult;
+use Moose;
+
+has success => (
+ is => 'rw',
+ isa => 'Bool'
+);
+
+has error => (
+ is => 'rw',
+
+
+);
+
+has value => (
+ is => 'rw',
+ isa => 'Str | Undef',
+ required => 0
+ );
+
+
+package PIE::Builder;
+use Moose;
+
+sub build_op_expression {
+ my ($self, $name, $args) = @_;
+ my $class = "PIE::Expression::$name";
+ die unless $class->meta->does_role("PIE::Evaluatable");
+
+ $class->new( map { $_ => $self->build_expression( $args->{$_} ) } keys %$args );
+}
+
+sub build_expression {
+ my ($self, $tree) = @_;
+ if (!ref($tree)) {
+ return PIE::Expression::String->new(value => $tree );
+ }
+ elsif (ref($tree) eq 'ARRAY') {
+ my ($func, @rest) = @$tree;
+ return PIE::Expression->new( elements => [$func, map { $self->build_expression($_) } @rest]);
+ }
+ elsif (ref($tree) eq 'HASH') {
+ return $self->build_op_expression($tree->{name}, $tree->{args});
+ }
+}
+
+
+sub build_expressions {
+ my $self = shift;
+ my $ops = shift;
+
+ return PIE::Lambda->new( nodes => [map { $self->build_expression($_) } @$ops ] );
+}
+
+package main;
+use Test::More qw'no_plan';
+
+my $trivial = PIE::Expression::True->new;
+
+my $evaluator = PIE::Evaluator->new;
+ok ($evaluator->run($trivial));
+ok($evaluator->result->success);
+ok($evaluator->result->value);
+
+
+my $false = PIE::Expression::False->new();
+my $eval2 = PIE::Evaluator->new;
+ok($eval2->run($false));
+ok(!$eval2->result->value);
+ok($eval2->result->success);
+
+
+my $if_true = PIE::Expression::IfThen->new( condition => PIE::Expression::True->new(), if_true => PIE::Expression::True->new(),if_false => PIE::Expression::False->new());
+
+my $eval3 = PIE::Evaluator->new();
+ok($eval3->run($if_true));
+ok($eval3->result->value);
+ok($eval2->result->success);
+
+my $if_false = PIE::Expression::IfThen->new( condition => PIE::Expression::False->new(), if_true => PIE::Expression::True->new(),if_false => PIE::Expression::False->new());
+
+my $eval4 = PIE::Evaluator->new();
+ok($eval4->run($if_false));
+ok(!$eval4->result->value);
+ok($eval4->result->success);
+
+my $eval5 = PIE::Evaluator->new;
+$eval5->set_named( 'match-regexp' => sub { my ($arg, $regexp) = @_;
+ return $arg =~ m/$regexp/; });
+
+
+my $match_p = PIE::Expression->new(elements => ['match-regexp',
+ PIE::Expression::String->new( value => 'I do love software'),
+ PIE::Expression::String->new( value =>'software')]);
+
+$eval5->run($match_p);
+ok ($eval5->result->success);
+
+is($eval5->result->value, 1);
+
+
+
+my $eval6 = PIE::Evaluator->new();
+
+$eval6->set_named( 'match-regexp' => sub { my ($arg, $regexp) = @_;
+ return $arg =~ m/$regexp/; });
+
+
+
+
+my $match_fail_p = PIE::Expression->new(elements => ['match-regexp',
+ PIE::Expression::String->new( value => 'I do love hardware'),
+ PIE::Expression::String->new( value =>'software')]);
+
+$eval6->run($match_fail_p);
+ok ($eval6->result->success);
+
+ok(!$eval6->result->value);
+
+
+my $script = PIE::Lambda->new(nodes => [
+ PIE::Expression::True->new()
+
+],
+
+);
+
+my $eval7 = PIE::Evaluator->new();
+$eval7->apply_script($script);
+ok($eval7->result->success);
+ok($eval7->result->value);
+
+
+
+my $script2 = PIE::Lambda->new(
+ nodes => [
+ $if_true ]);
+
+my $eval8 = PIE::Evaluator->new();
+$eval8->apply_script($script2);
+ok($eval8->result->success);
+ok($eval8->result->value);
+
+my $eval9 = PIE::Evaluator->new();
+
+$eval9->set_named( 'match-regexp' => sub { my ($arg, $regexp) = @_;
+ return $arg =~ m/$regexp/; });
+
+
+
+my $match_script = PIE::Lambda->new(
+
+ nodes => [
+ PIE::Expression->new(elements => ['match-regexp',
+ PIE::Expression::Symbol->new( symbol => 'tested-string') ,
+ PIE::Expression::Symbol->new( symbol => 'regex'),
+ ]) ],
+ bindings => [ 'tested-string', 'regex' ],
+);
+
+
+$eval9->apply_script($match_script, PIE::Expression::String->new( value => 'I do love hardware'),
+ PIE::Expression::String->new( value =>'software') );
+
+ok ($eval9->result->success);
+
+is($eval9->result->value, 1);
+my $tree =
+[
+ {
+ name => 'IfThen',
+ args => {
+ 'if_true' => 'hate',
+ 'if_false' => 'love',
+ 'condition' => [ 'regexp-match', 'software', 'foo' ],
+ }
+ }
+ ];
+
+
+my $builder = PIE::Builder->new();
+#use YAML;
+my $script = $builder->build_expressions($tree);
+
+my $eval10 = PIE::Evaluator->new();
+
+$eval10->set_named( 'regexp-match' => sub { my ($arg, $regexp) = @_;
+ return $arg =~ m/$regexp/; });
+
+
+warn Dumper($script); use Data::Dumper;
+$eval10->apply_script($script);
+ok($eval10->result->success);
+is($eval10->result->value,'love');
+
+
Added: pie/trunk/doc/yapperl.txt
==============================================================================
--- (empty file)
+++ pie/trunk/doc/yapperl.txt Wed May 21 02:35:11 2008
@@ -0,0 +1,319 @@
+Yatta! The Pinglin Control Framework
+
+PCF is designed as an scripting language for multiuser software.
+
+
+Basically, I don't want to let users write arbitrary programs.
+
+
+RT implementation plan:
+
+
+
+
+Uses in RT:
+ Replace scrips:
+ - on transaction, if some condition, perform some action
+ validate value for field foo
+ canonicalize value for field foo
+ get possible values for field foo
+ check user Alice's permission to update ticket foo
+ check user Alice's permission to show ticket 123's field 'abc'
+ before the user updates some ticket, run some action, possibly modifying the data, possibly rejecting the update
+
+
+Hooks in Jifty:
+
+ canonicalize field $FOO on action $TYPE
+ validate field $FOO on action $TYPE
+ before action of type $TYPE
+ after action of type $TYPE
+ "run manually"
+ "run at time"
+
+ ex: When I create a new task which matches "Bug: foo" add tasks: "Branch $projname" "Fix bug", "Hand off to QA"
+ When I check off a task "Fix bug", add a comment to the dependent task matching "QA" saying "your turn"
+
+ ex: 'every monday,'
+ find every task I updated last week
+ copy the notes added last week to a variable unless the notes match "jobhunt"
+
+ email my boss
+
+
+
+
+I want to give them snap-together lego bricks
+
+
+
+
+
+
+a framework for defining lego-like blocks
+an environment for building snap-together sets of blocks and naming them.
+an environment for executing the snap-togethers
+an easy way to embed calls to snap-togethers in my code (RT or Prophet or catalyst or whatevertyehfuckyou want. but not kitteh. definitely not kitteh)
+
+
+Just to name things:
+
+
+ a brick is an individual bit of code. it takes inputs.
+ does it return results or does it shove results in some input handed to it?
+
+
+ a block is essentially a named bricks built up of one or more blocks or bricks
+
+
+
+o Code
+ - How blocks are built and execcuted
+ - How to specify a brick's arguments/return values (as strongly typed as we can)
+ (Blocks arguments are always the topmost brick's arguments. Their return values are always the bottom-most brick's returnvalues.)
+ - How to link blocks together (making sure that a block's arguments match up with what the caller provides)
+ - How to coerce block arguments (or is this just an "int to str" brick, etc? that feels nice and clean)
+ - implicit coercion when it makes sense is a win.
+ - How to specify exceptions
+ - How to limit resource usage (infinite loops)
+o Interaction with system plugged to
+ - how existing models / methods are exported and used in YAPERL
+ - I think this is just done as a set of custom bricks provided by the existing system
+o How to find and invoke blocks (with arguments) from your existing system (and how to read the return values if any)
+
+
+
+
+
+
+
+
+each Thing has
+ one Thing Definition
+ one uuid
+ one name
+ many Properties
+
+each Property has
+ one PropertyDefinition
+ one or more values
+
+
+each ThingDefinition has
+ many PropertyDefinitions
+ one uuid
+ one name
+
+each PropertyDefinition has
+ one name
+ one uuid
+ one data_type
+ rule_hooks:
+ valid_values();
+ validate_value();
+ canoncalize_value();
+ before_set_value();
+ after_set_value();
+ before_load_value();
+ after_load_value();
+
+
+
+ rule_hooks:
+ before_create()
+ after_create();
+ before_load();
+ after_load();
+ before_delete();
+ after_delete();
+ before_set();
+ after_set();
+ before_read();
+ after_read();
+
+ # TODO: do we want special handlers for unknown properties?
+
+
+each Rule can return:
+ mutate_calling_args
+ abort with failure
+ abort with success
+ pass
+
+
+
+A given hook point defines:
+
+ a name
+ an object type
+
+
+A given rule implementation class defines:
+
+ a list of rule arguments it takes
+ a list of possible "subrules" hook points it provides
+
+
+A given RuleInstance has:
+
+ object_type:
+ enum of (TypeDefinition, AttributeDefinition)
+ object uuid
+ hook_name
+
+
+ virtual column
+ arguments
+
+ each rule:
+ * applies to a single object
+ either a TypeDefinition or an AttributeDefinition
+ * applies to a single trigger point.
+
+
+
+
+sub foo(Str $var) {
+ if ($var ~~ /software/) {
+ return 'hate';
+ }
+ else {
+ return 'love';
+ }
+}
+
+- cond
+ - expr:
+ - match
+ - $var
+ - software
+ - true: (block)
+ - return('hate')
+ - false: (block)
+ - return('love')
+
+
+#So, what's the case you're seeing being ambiguous?
+
+
+if(a) {FOO} else { BAR }
+X(a, FOO, BAR)
+
+And these are different because FOO and BAR are evaluated eagerly in the X(a,FOO,BAR) case?
+But if functions' arguments are evaluated lazily, it doesn't hurt.
+
+
+
+package PCF::Brick::Conditional::IfThenElse;
+use Moose;
+
+has condition => (
+ is 'ro',
+ isa 'PCF::Block'
+);
+
+has on_true => (
+ is 'ro',
+ isa 'PCF::Block');
+
+
+has on_false => (
+ is 'ro',
+ isa 'PCF::Block');
+
+sub exec {
+ my $self = shift;
+ my $result = $self->condition->exec;
+ if ($result->return_value) {
+ $self->on_true->exec;
+ } else {
+ $self->on_false->exec;
+ }
+}
+
+package PCF::Brick::Match::Regexp;
+use Moose;
+
+has regexp => (
+ is 'ro',
+ isa 'Regex');
+
+
+has argument => (
+ is 'ro',
+ isa 'PCF::Block' # in case of a raw string, it would be a PCF::Block::Constant
+);
+
+package PCF::Brick::Return;
+use Moose;
+
+has argument => (
+ is 'ro',
+ isa 'PCF::Block' # in case of a raw string, it would be a PCF::Block::Constant
+);
+
+
+sub exec {
+ my $self = shift;
+
+ my $result = $self->argument->exec;
+ PCF::Runtime::MagicallySignalRuntimeWeAreDone($result->return_value); #? sane?
+
+}
+
+
+package PCF::ExecResult;
+use Moose;
+
+has return_values => (
+ metaclass => "Collection::Array",
+ isa => "ArrayRef[PCF::Runtime::Scalar]",
+ is 'rw',
+ provides => {
+ push => "push",
+ pop => "pop",
+ },
+);
+
+has failed => (
+ is 'ro',
+ is 'Bool'
+ );
+
+
+package PCF::Block;
+use Moose;
+
+has name => (
+ is 'rw',
+ isa 'Str');
+
+
+package PCF::Runtime;
+
+sub load_block {}
+sub exec {}
+
+
+
+
+# a class to describe an op tree
+# a class to run an optree
+# primitives for basic ops
+ # run a named optree like it's a primitive
+
+# primitives for variables
+# a way to store an optree as a variable
+# a way to "access" the result of the optree
+
+
+
+
+# I'm not super-convinced by the p5 op definitions. but it might just be that I've been trained that XXXOP == dealing with broken p5 core
+# Is the goal here to basically define bricks by "what arguments they take and what arguments they return"?
+
+
+return = UNOP
+cond = LISTOP
+match = BINOP
+$var(PADSV) = SVOP?
Added: pie/trunk/lib/PIE.pm
==============================================================================
--- (empty file)
+++ pie/trunk/lib/PIE.pm Wed May 21 02:35:11 2008
@@ -0,0 +1,5 @@
+package PIE;
+
+our $VERSION = sqrt(-1);
+
+1;
Added: pie/trunk/lib/PIE/Builder.pm
==============================================================================
--- (empty file)
+++ pie/trunk/lib/PIE/Builder.pm Wed May 21 02:35:11 2008
@@ -0,0 +1,36 @@
+
+package PIE::Builder;
+use Moose;
+
+sub build_op_expression {
+ my ($self, $name, $args) = @_;
+ my $class = "PIE::Expression::$name";
+ die unless $class->meta->does_role("PIE::Evaluatable");
+
+ $class->new( map { $_ => $self->build_expression( $args->{$_} ) } keys %$args );
+}
+
+sub build_expression {
+ my ($self, $tree) = @_;
+ if (!ref($tree)) {
+ return PIE::Expression::String->new(value => $tree );
+ }
+ elsif (ref($tree) eq 'ARRAY') {
+ my ($func, @rest) = @$tree;
+ return PIE::Expression->new( elements => [$func, map { $self->build_expression($_) } @rest]);
+ }
+ elsif (ref($tree) eq 'HASH') {
+ return $self->build_op_expression($tree->{name}, $tree->{args});
+ }
+}
+
+
+sub build_expressions {
+ my $self = shift;
+ my $ops = shift;
+
+ return PIE::Lambda->new( nodes => [map { $self->build_expression($_) } @$ops ] );
+}
+
+
+1;
Added: pie/trunk/lib/PIE/Evaluatable.pm
==============================================================================
--- (empty file)
+++ pie/trunk/lib/PIE/Evaluatable.pm Wed May 21 02:35:11 2008
@@ -0,0 +1,7 @@
+
+package PIE::Evaluatable;
+use Moose::Role;
+
+requires 'evaluate';
+
+1;
Added: pie/trunk/lib/PIE/Evaluator.pm
==============================================================================
--- (empty file)
+++ pie/trunk/lib/PIE/Evaluator.pm Wed May 21 02:35:11 2008
@@ -0,0 +1,66 @@
+
+package PIE::Evaluator;
+use Moose;
+use MooseX::AttributeHelpers;
+use PIE::EvaluatorResult;
+
+
+has result => (
+ is => 'ro',
+ isa => 'PIE::EvaluatorResult',
+ default => sub { return PIE::EvaluatorResult->new()}
+ );
+
+has named => (
+ metaclass => 'Collection::Hash',
+ is => 'rw',
+ default => sub { {} },
+ isa => 'HashRef',
+ provides => {
+ get => 'get_named',
+ set => 'set_named',
+ });
+
+sub run {
+ my $self = shift;
+ my $expression = shift;
+ eval {
+ my $ret = $expression->evaluate($self);
+ $self->result->value($ret) ; # XXX TODO - we should be separating out success and value
+ $self->result->success(1);
+ };
+ if (my $err = $@) {
+ die $err; # for now
+
+ $self->result->success(0);
+ $self->result->error($err);
+ }
+
+ return 1;
+}
+
+sub resolve_name {
+ my ($self, $name) = @_;
+ $self->get_named($name);
+}
+
+
+sub apply_script {
+ my ($self, $lambda, @exp) = @_;
+ if (ref($lambda) eq 'CODE') {
+ $lambda->(map {$self->run($_); $self->result->value } @exp);
+ }
+ elsif ($lambda->isa("PIE::Lambda")) {
+ my $bindings = $lambda->bindings;
+ die "unmatched number of arguments" unless $#{$bindings} == $#exp;
+ # XXX: cleanup, unmask, etc
+ $self->set_named( $bindings->[$_] => $exp[$_] ) for 0.. $#exp;
+ $lambda->evaluate($self);
+ }
+ else {
+ die 'wtf';
+ }
+}
+
+
+1;
Added: pie/trunk/lib/PIE/EvaluatorResult.pm
==============================================================================
--- (empty file)
+++ pie/trunk/lib/PIE/EvaluatorResult.pm Wed May 21 02:35:11 2008
@@ -0,0 +1,23 @@
+
+package PIE::EvaluatorResult;
+use Moose;
+
+has success => (
+ is => 'rw',
+ isa => 'Bool'
+);
+
+has error => (
+ is => 'rw',
+
+
+);
+
+has value => (
+ is => 'rw',
+ isa => 'Str | Undef',
+ required => 0
+ );
+
+
+1;
Added: pie/trunk/lib/PIE/Expression.pm
==============================================================================
--- (empty file)
+++ pie/trunk/lib/PIE/Expression.pm Wed May 21 02:35:11 2008
@@ -0,0 +1,124 @@
+
+package PIE::Expression;
+use Moose;
+
+with 'PIE::Evaluatable';
+
+has elements => (
+ is => 'ro',
+ isa => 'ArrayRef');
+
+# (foo bar (orz 1 ))
+# === (eval 'foo bar (orz 1))
+# === (apply foo ((bar (orz 1))
+
+
+
+sub evaluate {
+ my ($self, $ev) = @_;
+ my $func = $self->elements->[0];
+ my @exp = @{ $self->elements }[1..$#{ $self->elements }];
+ my $lambda = $ev->resolve_name($func);
+ return $ev->apply_script($lambda, @exp);
+}
+
+
+package PIE::Expression::True;
+use Moose;
+
+extends 'PIE::Expression';
+
+sub evaluate {1}
+
+package PIE::Expression::False;
+use Moose;
+extends 'PIE::Expression::True';
+
+sub evaluate {
+ my $self = shift;
+ return ! $self->SUPER::evaluate();
+
+}
+
+package PIE::Expression::Loop;
+use Moose;
+extends 'PIE::Expression';
+
+has items => ( is => 'rw', isa => 'ArrayRef[PIE::Evaluatable]');
+has block => ( is => 'rw', isa => 'PIE::Evaluatable');
+
+sub evaluate {
+ my $self = shift;
+
+}
+
+package PIE::Expression::IfThen;
+use Moose;
+extends 'PIE::Expression';
+
+
+has condition => (
+ is => 'rw',
+ does => 'PIE::Evaluatable');
+
+has if_true => (
+ is => 'rw',
+ does => 'PIE::Evaluatable');
+
+has if_false => (
+ is => 'rw',
+ does => 'PIE::Evaluatable');
+
+
+sub arguments { return qw(condition if_true if_false)}
+
+
+sub evaluate {
+ my $self = shift;
+ my $evaluator = shift;
+ $evaluator->run($self->condition);
+
+
+ if ($evaluator->result->value) {
+
+ $evaluator->run($self->if_true);
+ return $evaluator->result->value;
+ } else {
+ $evaluator->run($self->if_false);
+ return $evaluator->result->value;
+ }
+}
+
+package PIE::Expression::String;
+use Moose;
+extends 'PIE::Expression';
+
+has value => (
+ is => 'rw',
+ isa => 'Str | Undef');
+
+
+sub evaluate {
+ my $self = shift;
+ return $self->value;
+
+}
+
+package PIE::Expression::Symbol;
+use Moose;
+extends 'PIE::Expression';
+
+has symbol => (
+ is => 'rw',
+ isa => 'Str');
+
+
+sub evaluate {
+ my ($self, $ev) = @_;
+ my $result = $ev->get_named($self->symbol);
+ warn $self->symbol;
+ warn $result;
+ return $result->isa('PIE::Expression') ? $ev->run($result) : $result; # XXX: figure out evaluation order here
+}
+
+1;
Added: pie/trunk/lib/PIE/Lambda.pm
==============================================================================
--- (empty file)
+++ pie/trunk/lib/PIE/Lambda.pm Wed May 21 02:35:11 2008
@@ -0,0 +1,28 @@
+
+package PIE::Lambda;
+use Moose; use MooseX::Params::Validate;
+with 'PIE::Evaluatable';
+
+has nodes => (
+ is => 'rw',
+ isa => 'ArrayRef',
+);
+
+has bindings => (
+ is => 'rw',
+ isa => 'ArrayRef[Str]');
+
+
+
+sub evaluate {
+ my $self = shift;
+ my $evaluator = shift;
+# my %args = validate(@_, { context => 1});
+ foreach my $node (@{$self->nodes}) {
+ $evaluator->run($node);
+
+ }
+
+}
+
+1;
Added: pie/trunk/t/01basic.t
==============================================================================
--- (empty file)
+++ pie/trunk/t/01basic.t Wed May 21 02:35:11 2008
@@ -0,0 +1,146 @@
+use Test::More qw'no_plan';
+
+use_ok('PIE::Expression');
+use_ok('PIE::Evaluator');
+use_ok('PIE::Lambda');
+use_ok('PIE::Builder');
+
+my $trivial = PIE::Expression::True->new;
+
+my $evaluator = PIE::Evaluator->new;
+ok ($evaluator->run($trivial));
+ok($evaluator->result->success);
+ok($evaluator->result->value);
+
+
+my $false = PIE::Expression::False->new();
+my $eval2 = PIE::Evaluator->new;
+ok($eval2->run($false));
+ok(!$eval2->result->value);
+ok($eval2->result->success);
+
+
+my $if_true = PIE::Expression::IfThen->new( condition => PIE::Expression::True->new(), if_true => PIE::Expression::True->new(),if_false => PIE::Expression::False->new());
+
+my $eval3 = PIE::Evaluator->new();
+ok($eval3->run($if_true));
+ok($eval3->result->value);
+ok($eval2->result->success);
+
+my $if_false = PIE::Expression::IfThen->new( condition => PIE::Expression::False->new(), if_true => PIE::Expression::True->new(),if_false => PIE::Expression::False->new());
+
+my $eval4 = PIE::Evaluator->new();
+ok($eval4->run($if_false));
+ok(!$eval4->result->value);
+ok($eval4->result->success);
+
+my $eval5 = PIE::Evaluator->new;
+$eval5->set_named( 'match-regexp' => sub { my ($arg, $regexp) = @_;
+ return $arg =~ m/$regexp/; });
+
+
+my $match_p = PIE::Expression->new(elements => ['match-regexp',
+ PIE::Expression::String->new( value => 'I do love software'),
+ PIE::Expression::String->new( value =>'software')]);
+
+$eval5->run($match_p);
+ok ($eval5->result->success);
+
+is($eval5->result->value, 1);
+
+
+
+my $eval6 = PIE::Evaluator->new();
+
+$eval6->set_named( 'match-regexp' => sub { my ($arg, $regexp) = @_;
+ return $arg =~ m/$regexp/; });
+
+
+
+
+my $match_fail_p = PIE::Expression->new(elements => ['match-regexp',
+ PIE::Expression::String->new( value => 'I do love hardware'),
+ PIE::Expression::String->new( value =>'software')]);
+
+$eval6->run($match_fail_p);
+ok ($eval6->result->success);
+
+ok(!$eval6->result->value);
+
+
+my $script = PIE::Lambda->new(nodes => [
+ PIE::Expression::True->new()
+
+],
+
+);
+
+my $eval7 = PIE::Evaluator->new();
+$eval7->apply_script($script);
+ok($eval7->result->success);
+ok($eval7->result->value);
+
+
+
+my $script2 = PIE::Lambda->new(
+ nodes => [
+ $if_true ]);
+
+my $eval8 = PIE::Evaluator->new();
+$eval8->apply_script($script2);
+ok($eval8->result->success);
+ok($eval8->result->value);
+
+my $eval9 = PIE::Evaluator->new();
+
+$eval9->set_named( 'match-regexp' => sub { my ($arg, $regexp) = @_;
+ return $arg =~ m/$regexp/; });
+
+
+
+my $match_script = PIE::Lambda->new(
+
+ nodes => [
+ PIE::Expression->new(elements => ['match-regexp',
+ PIE::Expression::Symbol->new( symbol => 'tested-string') ,
+ PIE::Expression::Symbol->new( symbol => 'regex'),
+ ]) ],
+ bindings => [ 'tested-string', 'regex' ],
+);
+
+
+$eval9->apply_script($match_script, PIE::Expression::String->new( value => 'I do love hardware'),
+ PIE::Expression::String->new( value =>'software') );
+
+ok ($eval9->result->success);
+
+is($eval9->result->value, 1);
+my $tree =
+[
+ {
+ name => 'IfThen',
+ args => {
+ 'if_true' => 'hate',
+ 'if_false' => 'love',
+ 'condition' => [ 'regexp-match', 'software', 'foo' ],
+ }
+ }
+ ];
+
+
+my $builder = PIE::Builder->new();
+#use YAML;
+my $script = $builder->build_expressions($tree);
+
+my $eval10 = PIE::Evaluator->new();
+
+$eval10->set_named( 'regexp-match' => sub { my ($arg, $regexp) = @_;
+ return $arg =~ m/$regexp/; });
+
+
+warn Dumper($script); use Data::Dumper;
+$eval10->apply_script($script);
+ok($eval10->result->success);
+is($eval10->result->value,'love');
+
+
More information about the Bps-public-commit
mailing list