t/10-recursion.t

   1 ## Test case donated by Stevan Little
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 25;
   7 use Data::Dumper;
   8
   9 BEGIN {
  10     package Interpreter;
  11     use Moose;
  12     use Moose::Util::TypeConstraints;
  13     use MooseX::Types::Structured qw(Dict Tuple);
  14     use MooseX::Types::Moose qw(
  15         Int
  16         Str
  17         ScalarRef
  18     );
  19     use MooseX::Types -declare => [qw(
  20         Var
  21         Const
  22         Pair
  23         Op
  24         BinOp
  25         Lambda
  26         App
  27         Expr
  28     )];
  29
  30     use Data::Dumper 'Dumper';
  31
  32     subtype Var()   => as ScalarRef;
  33     subtype Const() => as Int | Str;
  34     subtype Pair()  => Tuple[ Expr, Expr ];
  35
  36     enum Op() => qw[ + - ];
  37
  38     subtype BinOp()  => Tuple[ Expr, Op, Expr ];
  39     subtype Lambda() => Tuple[ Var, Expr ];
  40     subtype App()    => Tuple[ Lambda, Expr ];
  41     subtype Expr()   => as Var | Const | Pair | BinOp | Lambda | App;
  42
  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     }
  62
  63     sub run {
  64         my ($source, $e) = @_;
  65         $e ||= {};
  66         #use Data::Dumper; warn "run(e) => " . Dumper $e;
  67         return match $source,
  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 { $_ },
  74               App() => sub {
  75                              my ( $p, $body ) = @{ run( $_[0]->[0], $e ) };
  76                              $e->{ ${ $p } }  = run( $_[0]->[1], $e );
  77                              run( $body, $e );
  78                            },
  79              Pair() => sub { $_ },
  80              Expr() => sub { run($_, $e) },
  81                        sub { confess "[run] Bad Source:" . Dumper $_ };
  82     }
  83
  84     sub pprint {
  85         my ($source) = @_;
  86         return match $source,
  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 $_                  };
  96     }
  97 }
  98
  99 {
 100     BEGIN { Interpreter->import(':all') };
 101
 102     ok is_Var(\'x'), q{passes is_Var('x')};
 103
 104     ok is_Const(1), q{passes is_Const(1)};
 105     ok is_Const('Hello World'), q{passes is_Const};
 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};
 111
 112     ok is_Op('+'), q{passes is_Op('+')};
 113     ok is_Op('-'), q{passes is_Op('-')};
 114
 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])};
 118
 119     ok is_Lambda([ \'x', [ \'x', '+', \'x' ]]), q{passes is_Lambda};
 120     ok is_App([ [ \'x', [ \'x', '+', \'x' ]], 10 ]), q{passes is_App};
 121
 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 ]])};
 127
 128     my $source = [ [ \'x', [ \'x', '+', \'x' ]], 10 ];
 129
 130     is Interpreter::pprint($source),
 131     'App( Lambda( Var(x) BinOp( Var(x) Op(+) Var(x) ) ) Const(10) )',
 132     '... pretty printed correctly';
 133
 134     is Interpreter::run([ 1, '+', 1 ]), 2, '... eval-ed correctly';
 135
 136     is Interpreter::run([ 1, '+', [ 1, '+', 1 ] ]), 3, '... eval-ed correctly';
 137
 138     is_deeply Interpreter::run([ \'x', [ \'x', '+', \'x' ]]),
 139     [ \'x', [ \'x', '+', \'x' ]],
 140     '... eval-ed correctly';
 141
 142     is Interpreter::run($source), 20, '... eval-ed correctly';
 143
 144     is Interpreter::run(
 145         [
 146             [ \'x', [ \'x', '+', \'x' ] ],
 147             [ 2, '+', 2 ]
 148         ]
 149     ), 8, '... eval-ed correctly';
 150
 151 }
 152
 153