1 ## Test case donated by Stevan Little
6 use Test::More tests => 25;
12 use Moose::Util::TypeConstraints;
13 use MooseX::Types::Structured qw(Dict Tuple);
14 use MooseX::Types::Moose qw(
19 use MooseX::Types -declare => [qw(
30 use Data::Dumper 'Dumper';
32 subtype Var() => as ScalarRef;
33 subtype Const() => as Int | Str;
34 subtype Pair() => as Tuple[ Expr, Expr ];
36 enum Op() => [ qw[ + - ] ];
38 subtype BinOp() => as Tuple[ Expr, Op, Expr ];
39 subtype Lambda() => as Tuple[ Var, Expr ];
40 subtype App() => as Tuple[ Lambda, Expr ];
41 subtype Expr() => as Var | Const | Pair | BinOp | Lambda | App;
44 my ($to_match, @cases) = @_;
46 if (@cases % 2 != 0) {
47 $default = pop @cases;
50 my ($type, $action) = splice @cases, 0, 2;
51 #warn "Got " . Dumper($to_match) . " in " . $type->name;
52 if ($type->check($to_match)) {
54 return $action->($to_match);
59 return $default->($to_match) if $default;
64 my ($source, $e) = @_;
66 #use Data::Dumper; warn "run(e) => " . Dumper $e;
68 Var() => sub { $e->{ ${$_} } },
69 Const() => sub { $_[0] },
70 BinOp() => sub { $_->[1] eq '+'
71 ? ( run( $_->[0], $e ) + run( $_->[2], $e ) )
72 : ( run( $_->[0], $e ) - run( $_->[2], $e ) ) },
73 Lambda() => sub { $_ },
75 my ( $p, $body ) = @{ run( $_[0]->[0], $e ) };
76 $e->{ ${ $p } } = run( $_[0]->[1], $e );
80 Expr() => sub { run($_, $e) },
81 sub { confess "[run] Bad Source:" . Dumper $_ };
87 Var() => sub { 'Var(' . ${$_} . ')' },
88 Op() => sub { 'Op(' . $_ . ')' },
89 Const() => sub { 'Const(' . $_ . ')' },
90 BinOp() => sub { 'BinOp( ' . ( join ' ' => map { pprint($_) } @{$_} ) . ' )' },
91 Lambda() => sub { "Lambda( " . pprint($_->[0]) . ' ' . pprint($_->[1]) . " )" },
92 App() => sub { "App( " . pprint($_->[0]) . ' ' . pprint($_->[1]) . " )" },
93 Pair() => sub { 'Pair(' . pprint($_->[0]) . ' => ' . pprint($_->[1]) . ')' },
94 Expr() => sub { pprint($_) },
95 sub { confess "[pprint] Bad Source:" . Dumper $_ };
100 BEGIN { Interpreter->import(':all') };
102 ok is_Var(\'x'), q{passes is_Var('x')};
104 ok is_Const(1), q{passes is_Const(1)};
105 ok is_Const('Hello World'), q{passes is_Const};
107 ok is_Pair([ 'Hello', 'World' ]), q{passes is_Pair};
108 ok is_Pair([ \'Hello', 'World' ]), q{passes is_Pair};
109 ok is_Pair([ \'Hello', 100 ]), q{passes is_Pair};
110 ok is_Pair([ \'Hello', [ 1, '+', 1] ]), q{passes is_Pair};
112 ok is_Op('+'), q{passes is_Op('+')};
113 ok is_Op('-'), q{passes is_Op('-')};
115 ok is_BinOp([ 1, '+', 1]), q{passes is_BinOp([ 1, '+', 1])};
116 ok is_BinOp([ '+', '+', '+' ]), q{passes is_BinOp([ '+', '+', '+' ])};
117 ok is_BinOp([ 1, '+', [ 1, '+', 1 ]]), q{passes is_BinOp([ 1, '+', 1])};
119 ok is_Lambda([ \'x', [ \'x', '+', \'x' ]]), q{passes is_Lambda};
120 ok is_App([ [ \'x', [ \'x', '+', \'x' ]], 10 ]), q{passes is_App};
122 ok Expr->check([ 11, '+', 12]), '... check is supported';
123 ok is_Expr(\'x'), q{passes is_Expr(\'x')};
124 ok is_Expr(10), q{passes is_Expr(10)};
125 ok is_Expr([ 1, '+', 1]), q{passes is_Expr([ 1, '+', 1])};
126 ok is_Expr([ 1, '+', [ 1, '+', 1 ]]), q{passes is_Expr([ 1, '+', [ 1, '+', 1 ]])};
128 my $source = [ [ \'x', [ \'x', '+', \'x' ]], 10 ];
130 is Interpreter::pprint($source),
131 'App( Lambda( Var(x) BinOp( Var(x) Op(+) Var(x) ) ) Const(10) )',
132 '... pretty printed correctly';
134 is Interpreter::run([ 1, '+', 1 ]), 2, '... eval-ed correctly';
136 is Interpreter::run([ 1, '+', [ 1, '+', 1 ] ]), 3, '... eval-ed correctly';
138 is_deeply Interpreter::run([ \'x', [ \'x', '+', \'x' ]]),
139 [ \'x', [ \'x', '+', \'x' ]],
140 '... eval-ed correctly';
142 is Interpreter::run($source), 20, '... eval-ed correctly';
146 [ \'x', [ \'x', '+', \'x' ] ],
149 ), 8, '... eval-ed correctly';