use MooseX::Types::Structured qw(Dict Tuple);
use MooseX::Types::Moose qw(
Int
- Str
+ Str
ScalarRef
);
use MooseX::Types -declare => [qw(
Var
Const
Pair
- Op
+ Op
BinOp
- Lambda
- App
+ Lambda
+ App
Expr
)];
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 '+'
+ 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 {
+ : ( 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 { $_ },
+ },
+ 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(' . $_ . ')' },
+ 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]) . ')' },
+ 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_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 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(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 ]])};
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 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';
-
+ '... eval-ed correctly';
+
+ is Interpreter::run($source), 20, '... eval-ed correctly';
+
is Interpreter::run(
[
[ \'x', [ \'x', '+', \'x' ] ],
[ 2, '+', 2 ]
]
- ), 8, '... eval-ed correctly';
-
+ ), 8, '... eval-ed correctly';
+
}
ok $hash_tailed_dict->check({name=>'Vanessa Li', age=>35, more1=>1,more2=>2}), 'correct pass with tail';
ok !$hash_tailed_dict->check({name=>'Vanessa Li', age=>35, more1=>1,more2=>"aa"}), 'correct fail with tail';
-__END__
-
-my $hash_tailed_tuple =
- subtype 'hash_tailed_tuple',
- as Tuple[
- Int,
- Str,
- slurpy HashRef[Int],
- ];
-
-ok !$hash_tailed_tuple->check(['ss',1]), 'correct fail';
-ok $hash_tailed_tuple->check([1,'ss']), 'correct pass';
-ok !$hash_tailed_tuple->check({}), 'correct fail';
-ok $hash_tailed_tuple->check([1,'hello',age=>25,zip=>10533]), 'correct pass with tail';
-ok !$hash_tailed_tuple->check([1,'hello',age=>25,name=>'john']), 'correct fail with tail';
-
-my $array_tailed_dict =
- subtype 'hash_tailed_dict',
- as Dict[
- name=>Str,
- age=>Int,
- slurpy ArrayRef[Int],
- ];
-
-ok !$array_tailed_dict->check({name=>'john',age=>'napiorkowski'}), 'correct fail';
-ok $array_tailed_dict->check({name=>'Vanessa Li', age=>35}), 'correct pass';
-ok !$array_tailed_dict->check([]), 'correct fail';
-ok $array_tailed_dict->check({name=>'Vanessa Li', age=>35, 1,2,3}), 'correct pass with tail';
-ok !$array_tailed_dict->check({name=>'Vanessa Li', age=>35, 1, "hello"}), 'correct fail with tail';
like $simple_tuple->validate(['a','b']),
qr/failed for 'simple_tuple' with value \[ "a", "b" \]/,
'Correctly failed due to "a" not an Int';
-
+
like $simple_tuple->validate([1,$simple_tuple]),
qr/Validation failed for 'simple_tuple' with value \[ 1, MooseX::Meta::TypeConstraint::Structured/,
'Correctly failed due to object not a Str';
like $simple_dict->validate([1,2]),
qr/ with value \[ 1, 2 \]/,
'Wrong basic type';
-
+
like $simple_dict->validate({name=>'John',age=>'a'}),
qr/failed for 'Int' with value a/,
'Correctly failed due to age not an Int';
-
+
like $simple_dict->validate({name=>$simple_dict,age=>1}),
qr/with value { age: 1, name: MooseX:/,
'Correctly failed due to object not a Str';
like $simple_dict->validate({name=>'Vincent', age=>15,extra=>'morethanIneed'}),
qr/More values than Type Constraints!/,
'Too Many values';
-
+
## TODO some with Optional (or Maybe) and slurpy
-
+
my $optional_tuple = subtype 'optional_tuple', as Tuple[Int,Optional[Str]];
my $optional_dict = subtype 'optional_dict', as Dict[name=>Str,age=>Optional[Int]];
-
+
like $optional_tuple->validate({a=>1,b=>2}),
qr/Validation failed for 'optional_tuple' with value { a: 1, b: 2 }/,
'Wrong basic type';
like $optional_tuple->validate(['a','b']),
qr/failed for 'Int' with value a/,
'Correctly failed due to "a" not an Int';
-
+
like $optional_tuple->validate([1,$simple_tuple]),
qr/failed for 'MooseX::Types::Structured::Optional\[Str\]' with value MooseX/,
'Correctly failed due to object not a Str';
like $optional_dict->validate([1,2]),
qr/ with value \[ 1, 2 \]/,
'Wrong basic type';
-
+
like $optional_dict->validate({name=>'John',age=>'a'}),
qr/Validation failed for 'MooseX::Types::Structured::Optional\[Int\]' with value a/,
'Correctly failed due to age not an Int';
-
+
like $optional_dict->validate({name=>$simple_dict,age=>1}),
qr/with value { age: 1, name: MooseX:/,
'Correctly failed due to object not a Str';
like $optional_dict->validate({name=>'Vincent', age=>15,extra=>'morethanIneed'}),
qr/More values than Type Constraints!/,
'Too Many values';
-
+
## Deeper constraints
my $deep_tuple = subtype 'deep_tuple',
age=>Int,
],
];
-
+
ok $deep_tuple->check([1,{a=>2},{name=>'Vincent',age=>15}]),
'Good Constraint';
-
+
like $deep_tuple->validate([1,{a=>2},{name=>'Vincent',age=>'Hello'}]),
qr/Error is: Validation failed for 'MooseX::Types::Structured::Dict\[name,Str,age,Int\]'/,
'Example deeper error';
-
+
## Success Tests...
ok !$deep_tuple->validate([1,{a=>2},{name=>'John',age=>40}]), 'Validates ok';
projects / gitmo/MooseX-Types-Structured.git / commitdiff