[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