## 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
ScalarRef
);
use MooseX::Types -declare => [qw(
Var
Const
Pair
Op
BinOp
Lambda
App
Expr
)];
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;
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;
}
}
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 $_ };
}
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 $_ };
}
}
{
BEGIN { Interpreter->import(':all') };
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_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';
}