Commit | Line | Data |
2f7785a3 |
1 | ## Test case donated by Stevan Little |
07a8693b |
2 | |
372f551c |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use Test::More tests => 25; |
7 | use Data::Dumper; |
8 | |
07a8693b |
9 | BEGIN { |
10 | package Interpreter; |
11 | use Moose; |
12 | use Moose::Util::TypeConstraints; |
13 | use MooseX::Types::Structured qw(Dict Tuple); |
372f551c |
14 | use MooseX::Types::Moose qw( |
c5d806b4 |
15 | Int |
9eb6e8c6 |
16 | Str |
372f551c |
17 | ScalarRef |
18 | ); |
07a8693b |
19 | use MooseX::Types -declare => [qw( |
20 | Var |
21 | Const |
372f551c |
22 | Pair |
9eb6e8c6 |
23 | Op |
372f551c |
24 | BinOp |
9eb6e8c6 |
25 | Lambda |
26 | App |
07a8693b |
27 | Expr |
28 | )]; |
29 | |
372f551c |
30 | use Data::Dumper 'Dumper'; |
31 | |
32 | subtype Var() => as ScalarRef; |
33 | subtype Const() => as Int | Str; |
0e914b09 |
34 | subtype Pair() => as Tuple[ Expr, Expr ]; |
372f551c |
35 | |
36 | enum Op() => qw[ + - ]; |
37 | |
0e914b09 |
38 | subtype BinOp() => as Tuple[ Expr, Op, Expr ]; |
39 | subtype Lambda() => as Tuple[ Var, Expr ]; |
40 | subtype App() => as Tuple[ Lambda, Expr ]; |
372f551c |
41 | subtype Expr() => as Var | Const | Pair | BinOp | Lambda | App; |
07a8693b |
42 | |
372f551c |
43 | sub match { |
44 | my ($to_match, @cases) = @_; |
45 | my $default; |
46 | if (@cases % 2 != 0) { |
47 | $default = pop @cases; |
48 | } |
49 | while (@cases) { |
50 | my ($type, $action) = splice @cases, 0, 2; |
51 | #warn "Got " . Dumper($to_match) . " in " . $type->name; |
52 | if ($type->check($to_match)) { |
53 | local $_ = $to_match; |
54 | return $action->($to_match); |
55 | } |
56 | } |
57 | { |
58 | local $_ = $to_match; |
59 | return $default->($to_match) if $default; |
60 | } |
61 | } |
07a8693b |
62 | |
372f551c |
63 | sub run { |
64 | my ($source, $e) = @_; |
65 | $e ||= {}; |
66 | #use Data::Dumper; warn "run(e) => " . Dumper $e; |
9eb6e8c6 |
67 | return match $source, |
68 | Var() => sub { $e->{ ${$_} } }, |
69 | Const() => sub { $_[0] }, |
70 | BinOp() => sub { $_->[1] eq '+' |
372f551c |
71 | ? ( run( $_->[0], $e ) + run( $_->[2], $e ) ) |
9eb6e8c6 |
72 | : ( run( $_->[0], $e ) - run( $_->[2], $e ) ) }, |
73 | Lambda() => sub { $_ }, |
74 | App() => sub { |
372f551c |
75 | my ( $p, $body ) = @{ run( $_[0]->[0], $e ) }; |
76 | $e->{ ${ $p } } = run( $_[0]->[1], $e ); |
77 | run( $body, $e ); |
9eb6e8c6 |
78 | }, |
79 | Pair() => sub { $_ }, |
372f551c |
80 | Expr() => sub { run($_, $e) }, |
81 | sub { confess "[run] Bad Source:" . Dumper $_ }; |
82 | } |
07a8693b |
83 | |
372f551c |
84 | sub pprint { |
85 | my ($source) = @_; |
9eb6e8c6 |
86 | return match $source, |
87 | Var() => sub { 'Var(' . ${$_} . ')' }, |
88 | Op() => sub { 'Op(' . $_ . ')' }, |
89 | Const() => sub { 'Const(' . $_ . ')' }, |
372f551c |
90 | BinOp() => sub { 'BinOp( ' . ( join ' ' => map { pprint($_) } @{$_} ) . ' )' }, |
91 | Lambda() => sub { "Lambda( " . pprint($_->[0]) . ' ' . pprint($_->[1]) . " )" }, |
9eb6e8c6 |
92 | App() => sub { "App( " . pprint($_->[0]) . ' ' . pprint($_->[1]) . " )" }, |
93 | Pair() => sub { 'Pair(' . pprint($_->[0]) . ' => ' . pprint($_->[1]) . ')' }, |
372f551c |
94 | Expr() => sub { pprint($_) }, |
95 | sub { confess "[pprint] Bad Source:" . Dumper $_ }; |
96 | } |
07a8693b |
97 | } |
98 | |
99 | { |
07a8693b |
100 | BEGIN { Interpreter->import(':all') }; |
07a8693b |
101 | |
372f551c |
102 | ok is_Var(\'x'), q{passes is_Var('x')}; |
9eb6e8c6 |
103 | |
07a8693b |
104 | ok is_Const(1), q{passes is_Const(1)}; |
105 | ok is_Const('Hello World'), q{passes is_Const}; |
9eb6e8c6 |
106 | |
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}; |
07a8693b |
111 | |
112 | ok is_Op('+'), q{passes is_Op('+')}; |
113 | ok is_Op('-'), q{passes is_Op('-')}; |
07a8693b |
114 | |
372f551c |
115 | ok is_BinOp([ 1, '+', 1]), q{passes is_BinOp([ 1, '+', 1])}; |
116 | ok is_BinOp([ '+', '+', '+' ]), q{passes is_BinOp([ '+', '+', '+' ])}; |
9eb6e8c6 |
117 | ok is_BinOp([ 1, '+', [ 1, '+', 1 ]]), q{passes is_BinOp([ 1, '+', 1])}; |
118 | |
119 | ok is_Lambda([ \'x', [ \'x', '+', \'x' ]]), q{passes is_Lambda}; |
120 | ok is_App([ [ \'x', [ \'x', '+', \'x' ]], 10 ]), q{passes is_App}; |
372f551c |
121 | |
122 | ok Expr->check([ 11, '+', 12]), '... check is supported'; |
123 | ok is_Expr(\'x'), q{passes is_Expr(\'x')}; |
9eb6e8c6 |
124 | ok is_Expr(10), q{passes is_Expr(10)}; |
07a8693b |
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 ]])}; |
07a8693b |
127 | |
372f551c |
128 | my $source = [ [ \'x', [ \'x', '+', \'x' ]], 10 ]; |
07a8693b |
129 | |
372f551c |
130 | is Interpreter::pprint($source), |
131 | 'App( Lambda( Var(x) BinOp( Var(x) Op(+) Var(x) ) ) Const(10) )', |
132 | '... pretty printed correctly'; |
9eb6e8c6 |
133 | |
134 | is Interpreter::run([ 1, '+', 1 ]), 2, '... eval-ed correctly'; |
135 | |
136 | is Interpreter::run([ 1, '+', [ 1, '+', 1 ] ]), 3, '... eval-ed correctly'; |
137 | |
372f551c |
138 | is_deeply Interpreter::run([ \'x', [ \'x', '+', \'x' ]]), |
139 | [ \'x', [ \'x', '+', \'x' ]], |
9eb6e8c6 |
140 | '... eval-ed correctly'; |
141 | |
142 | is Interpreter::run($source), 20, '... eval-ed correctly'; |
143 | |
372f551c |
144 | is Interpreter::run( |
145 | [ |
146 | [ \'x', [ \'x', '+', \'x' ] ], |
147 | [ 2, '+', 2 ] |
148 | ] |
9eb6e8c6 |
149 | ), 8, '... eval-ed correctly'; |
150 | |
372f551c |
151 | } |
07a8693b |
152 | |
153 | |