## Test case donated by Stevan Little
+use strict;
+use warnings;
+
+use Test::More tests => 25;
+use Data::Dumper;
+
BEGIN {
package Interpreter;
use Moose;
use Moose::Util::TypeConstraints;
use MooseX::Types::Structured qw(Dict Tuple);
- use MooseX::Types::Moose qw(Int Str);
+ use MooseX::Types::Moose qw(
+ Int
+ Str
+ ScalarRef
+ );
use MooseX::Types -declare => [qw(
Var
Const
- Op
+ Pair
+ Op
+ BinOp
+ Lambda
+ App
Expr
)];
- subtype Var() => as Str();
+ use Data::Dumper 'Dumper';
+
+ subtype Var() => as ScalarRef;
+ subtype Const() => as Int | Str;
+ subtype Pair() => as Tuple[ Expr, Expr ];
+
+ enum Op() => qw[ + - ];
+
+ subtype BinOp() => as Tuple[ Expr, Op, Expr ];
+ subtype Lambda() => as Tuple[ Var, Expr ];
+ subtype App() => as Tuple[ Lambda, Expr ];
+ subtype Expr() => as Var | Const | Pair | BinOp | Lambda | App;
- subtype Const() => as Int() | Str();
+ sub match {
+ my ($to_match, @cases) = @_;
+ my $default;
+ if (@cases % 2 != 0) {
+ $default = pop @cases;
+ }
+ while (@cases) {
+ my ($type, $action) = splice @cases, 0, 2;
+ #warn "Got " . Dumper($to_match) . " in " . $type->name;
+ if ($type->check($to_match)) {
+ local $_ = $to_match;
+ return $action->($to_match);
+ }
+ }
+ {
+ local $_ = $to_match;
+ return $default->($to_match) if $default;
+ }
+ }
- enum Op() => qw[ + - ^ ];
+ sub run {
+ my ($source, $e) = @_;
+ $e ||= {};
+ #use Data::Dumper; warn "run(e) => " . Dumper $e;
+ return match $source,
+ Var() => sub { $e->{ ${$_} } },
+ Const() => sub { $_[0] },
+ BinOp() => sub { $_->[1] eq '+'
+ ? ( run( $_->[0], $e ) + run( $_->[2], $e ) )
+ : ( run( $_->[0], $e ) - run( $_->[2], $e ) ) },
+ Lambda() => sub { $_ },
+ App() => sub {
+ my ( $p, $body ) = @{ run( $_[0]->[0], $e ) };
+ $e->{ ${ $p } } = run( $_[0]->[1], $e );
+ run( $body, $e );
+ },
+ Pair() => sub { $_ },
+ Expr() => sub { run($_, $e) },
+ sub { confess "[run] Bad Source:" . Dumper $_ };
+ }
- subtype Expr() => as
- Const()
- | Tuple([Expr(), Op(), Expr()]) # binop
- | Var();
+ sub pprint {
+ my ($source) = @_;
+ return match $source,
+ Var() => sub { 'Var(' . ${$_} . ')' },
+ Op() => sub { 'Op(' . $_ . ')' },
+ Const() => sub { 'Const(' . $_ . ')' },
+ BinOp() => sub { 'BinOp( ' . ( join ' ' => map { pprint($_) } @{$_} ) . ' )' },
+ Lambda() => sub { "Lambda( " . pprint($_->[0]) . ' ' . pprint($_->[1]) . " )" },
+ App() => sub { "App( " . pprint($_->[0]) . ' ' . pprint($_->[1]) . " )" },
+ Pair() => sub { 'Pair(' . pprint($_->[0]) . ' => ' . pprint($_->[1]) . ')' },
+ Expr() => sub { pprint($_) },
+ sub { confess "[pprint] Bad Source:" . Dumper $_ };
+ }
}
{
- package Foo;
BEGIN { Interpreter->import(':all') };
- use Test::More 'no_plan';
- ok is_Var('x'), q{passes is_Var('x')};
+ ok is_Var(\'x'), q{passes is_Var('x')};
+
ok is_Const(1), q{passes is_Const(1)};
ok is_Const('Hello World'), q{passes is_Const};
+
+ ok is_Pair([ 'Hello', 'World' ]), q{passes is_Pair};
+ ok is_Pair([ \'Hello', 'World' ]), q{passes is_Pair};
+ ok is_Pair([ \'Hello', 100 ]), q{passes is_Pair};
+ ok is_Pair([ \'Hello', [ 1, '+', 1] ]), q{passes is_Pair};
ok is_Op('+'), q{passes is_Op('+')};
ok is_Op('-'), q{passes is_Op('-')};
- ok is_Op('^'), q{passes is_Op('^')};
- ok Expr->check([ 11, '+', 12]), '';
+ ok is_BinOp([ 1, '+', 1]), q{passes is_BinOp([ 1, '+', 1])};
+ ok is_BinOp([ '+', '+', '+' ]), q{passes is_BinOp([ '+', '+', '+' ])};
+ ok is_BinOp([ 1, '+', [ 1, '+', 1 ]]), q{passes is_BinOp([ 1, '+', 1])};
+
+ ok is_Lambda([ \'x', [ \'x', '+', \'x' ]]), q{passes is_Lambda};
+ ok is_App([ [ \'x', [ \'x', '+', \'x' ]], 10 ]), q{passes is_App};
+
+ ok Expr->check([ 11, '+', 12]), '... check is supported';
+ ok is_Expr(\'x'), q{passes is_Expr(\'x')};
+ ok is_Expr(10), q{passes is_Expr(10)};
ok is_Expr([ 1, '+', 1]), q{passes is_Expr([ 1, '+', 1])};
ok is_Expr([ 1, '+', [ 1, '+', 1 ]]), q{passes is_Expr([ 1, '+', [ 1, '+', 1 ]])};
-}
-
-
+ my $source = [ [ \'x', [ \'x', '+', \'x' ]], 10 ];
+ is Interpreter::pprint($source),
+ 'App( Lambda( Var(x) BinOp( Var(x) Op(+) Var(x) ) ) Const(10) )',
+ '... pretty printed correctly';
+
+ is Interpreter::run([ 1, '+', 1 ]), 2, '... eval-ed correctly';
+
+ is Interpreter::run([ 1, '+', [ 1, '+', 1 ] ]), 3, '... eval-ed correctly';
+
+ is_deeply Interpreter::run([ \'x', [ \'x', '+', \'x' ]]),
+ [ \'x', [ \'x', '+', \'x' ]],
+ '... eval-ed correctly';
+
+ is Interpreter::run($source), 20, '... eval-ed correctly';
+
+ is Interpreter::run(
+ [
+ [ \'x', [ \'x', '+', \'x' ] ],
+ [ 2, '+', 2 ]
+ ]
+ ), 8, '... eval-ed correctly';
+
+}