--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 25;
+use Test::Exception;
+
+use Mouse::Util::TypeConstraints;
+
+# some simple type dispatching ...
+
+subtype 'Null'
+ => as 'ArrayRef'
+ => where { scalar @{$_} == 0 };
+
+sub head {
+ match_on_type @_ =>
+ Null => sub { die "Cannot get the head of Null" },
+ ArrayRef => sub { $_->[0] };
+}
+
+sub tail {
+ match_on_type @_ =>
+ Null => sub { die "Cannot get the tail of Null" },
+ ArrayRef => sub { [ @{ $_ }[ 1 .. $#{ $_ } ] ] };
+}
+
+sub len {
+ match_on_type @_ =>
+ Null => sub { 0 },
+ ArrayRef => sub { len( tail( $_ ) ) + 1 };
+}
+
+sub rev {
+ match_on_type @_ =>
+ Null => sub { [] },
+ ArrayRef => sub { [ @{ rev( tail( $_ ) ) }, head( $_ ) ] };
+}
+
+is( len( [] ), 0, '... got the right length');
+is( len( [ 1 ] ), 1, '... got the right length');
+is( len( [ 1 .. 5 ] ), 5, '... got the right length');
+is( len( [ 1 .. 50 ] ), 50, '... got the right length');
+
+is_deeply(
+ rev( [ 1 .. 5 ] ),
+ [ reverse 1 .. 5 ],
+ '... got the right reversed value'
+);
+
+# break down a Maybe Type ...
+
+sub break_it_down {
+ match_on_type shift,
+ 'Maybe[Str]' => sub {
+ match_on_type $_ =>
+ 'Undef' => sub { 'undef' },
+ 'Str' => sub { $_ }
+ },
+ sub { 'default' }
+}
+
+
+is( break_it_down( 'FOO' ), 'FOO', '... got the right value');
+is( break_it_down( [] ), 'default', '... got the right value');
+is( break_it_down( undef ), 'undef', '... got the right value');
+is( break_it_down(), 'undef', '... got the right value');
+
+# checking against enum types
+
+enum RGB => qw[ red green blue ];
+enum CMYK => qw[ cyan magenta yellow black ];
+
+sub is_acceptable_color {
+ match_on_type shift,
+ 'RGB' => sub { 'RGB' },
+ 'CMYK' => sub { 'CMYK' },
+ sub { die "bad color $_" };
+}
+
+is( is_acceptable_color( 'blue' ), 'RGB', '... got the right value');
+is( is_acceptable_color( 'green' ), 'RGB', '... got the right value');
+is( is_acceptable_color( 'red' ), 'RGB', '... got the right value');
+is( is_acceptable_color( 'cyan' ), 'CMYK', '... got the right value');
+is( is_acceptable_color( 'magenta' ), 'CMYK', '... got the right value');
+is( is_acceptable_color( 'yellow' ), 'CMYK', '... got the right value');
+is( is_acceptable_color( 'black' ), 'CMYK', '... got the right value');
+
+dies_ok {
+ is_acceptable_color( 'orange' )
+} '... got the exception';
+
+## using it in an OO context
+
+{
+ package LinkedList;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ has 'next' => (
+ is => 'ro',
+ isa => __PACKAGE__,
+ lazy => 1,
+ default => sub { __PACKAGE__->new },
+ predicate => 'has_next'
+ );
+
+ sub pprint {
+ my $list = shift;
+ match_on_type $list =>
+ subtype(
+ as 'LinkedList',
+ where { ! $_->has_next }
+ ) => sub { '[]' },
+ 'LinkedList' => sub { '[' . $_->next->pprint . ']' };
+ }
+}
+
+my $l = LinkedList->new;
+is($l->pprint, '[]', '... got the right pprint');
+$l->next;
+is($l->pprint, '[[]]', '... got the right pprint');
+$l->next->next;
+is($l->pprint, '[[[]]]', '... got the right pprint');
+$l->next->next->next;
+is($l->pprint, '[[[[]]]]', '... got the right pprint');
+
+# basic data dumper
+
+{
+ package Foo;
+ use Mouse;
+
+ sub to_string { 'Foo()' }
+}
+
+use B;
+
+sub ppprint {
+ my $x = shift;
+ match_on_type $x =>
+ HashRef => sub {
+ my $hash = shift;
+ '{ ' . (join ", " => map {
+ $_ . ' => ' . ppprint( $hash->{ $_ } )
+ } sort keys %$hash ) . ' }' },
+ ArrayRef => sub {
+ my $array = shift;
+ '[ ' . (join ", " => map { ppprint( $_ ) } @$array ) . ' ]' },
+ CodeRef => sub { 'sub { ... }' },
+ RegexpRef => sub { 'qr/' . $_ . '/' },
+ GlobRef => sub { '*' . B::svref_2object($_)->NAME },
+ Object => sub { $_->can('to_string') ? $_->to_string : $_ },
+ ScalarRef => sub { '\\' . ppprint( ${$_} ) },
+ Num => sub { $_ },
+ Str => sub { '"'. $_ . '"' },
+ Undef => sub { 'undef' },
+ => sub { die "I don't know what $_ is" };
+}
+
+is(
+ ppprint(
+ {
+ one => [ 1, 2, "three", 4, "five", \(my $x = "six") ],
+ two => undef,
+ three => sub { "OH HAI" },
+ four => qr/.*?/,
+ five => \*ppprint,
+ six => Foo->new,
+ }
+ ),
+ '{ five => *ppprint, four => qr/(?-xism:.*?)/, one => [ 1, 2, "three", 4, "five", \"six" ], six => Foo(), three => sub { ... }, two => undef }',
+ '... got the right pretty printed values'
+);
+
+# simple JSON serializer
+
+sub to_json {
+ my $x = shift;
+ match_on_type $x =>
+ HashRef => sub {
+ my $hash = shift;
+ '{ ' . (join ", " => map {
+ '"' . $_ . '" : ' . to_json( $hash->{ $_ } )
+ } sort keys %$hash ) . ' }' },
+ ArrayRef => sub {
+ my $array = shift;
+ '[ ' . (join ", " => map { to_json( $_ ) } @$array ) . ' ]' },
+ Num => sub { $_ },
+ Str => sub { '"'. $_ . '"' },
+ Undef => sub { 'null' },
+ => sub { die "$_ is not acceptable json type" };
+}
+
+is(
+ to_json( { one => 1, two => 2 } ),
+ '{ "one" : 1, "two" : 2 }',
+ '... got our valid JSON'
+);
+
+is(
+ to_json( {
+ one => [ 1, 2, 3, 4 ],
+ two => undef,
+ three => "Hello World"
+ } ),
+ '{ "one" : [ 1, 2, 3, 4 ], "three" : "Hello World", "two" : null }',
+ '... got our valid JSON'
+);
+
+
+# some error cases
+
+sub not_enough_matches {
+ my $x = shift;
+ match_on_type $x =>
+ Undef => sub { 'hello undef world' },
+ CodeRef => sub { $_->('Hello code ref world') };
+}
+
+throws_ok {
+ not_enough_matches( [] )
+} qr/No cases matched for /, '... not enough matches';
+
+
+
+