Doh, the SYNOPSIS was totally wrong.
[gitmo/Moose.git] / t / 200_examples / 003_example.t
1 #!/usr/bin/perl
2
3 use strict;
4 use warnings;
5
6 use Test::More tests => 30;
7 use Test::Exception;
8
9 sub U {
10     my $f = shift;
11     sub { $f->($f, @_) };
12 }
13
14 sub Y {
15     my $f = shift;
16     U(sub { my $h = shift; sub { $f->(U($h)->())->(@_) } })->();
17 }
18
19 {
20     package List;
21     use Moose::Role;
22     
23     has '_list' => (
24         is       => 'ro',
25         isa      => 'ArrayRef', 
26         init_arg => '::',
27         default  => sub { [] }
28     );
29     
30     sub head { (shift)->_list->[0] }
31     sub tail {
32         my $self = shift;
33         $self->new(
34             '::' => [ 
35                 @{$self->_list}[1 .. $#{$self->_list}] 
36             ]
37         );
38     }  
39     
40     sub print {
41         join ", " => @{$_[0]->_list};
42     }     
43     
44     package List::Immutable;
45     use Moose::Role;
46     
47     requires 'head';
48     requires 'tail';    
49     
50     sub is_empty { not defined ($_[0]->head) }
51     
52     sub length {
53         my $self = shift;
54         (::Y(sub {
55             my $redo = shift;
56             sub {
57                 my ($list, $acc) = @_;
58                 return $acc if $list->is_empty;
59                 $redo->($list->tail, $acc + 1);
60             }
61         }))->($self, 0);
62     }
63     
64     sub apply {
65         my ($self, $function) = @_;
66         (::Y(sub {
67             my $redo = shift;
68             sub {
69                 my ($list, $func, $acc) = @_;
70                 return $list->new('::' => $acc) 
71                     if $list->is_empty;
72                 $redo->(
73                     $list->tail, 
74                     $func,
75                     [ @{$acc}, $func->($list->head) ]
76                 );
77             }
78         }))->($self, $function, []);        
79     }
80     
81     package My::List1;
82     use Moose;
83     
84     ::lives_ok {
85         with 'List', 'List::Immutable';
86     } '... successfully composed roles together';
87     
88     package My::List2;
89     use Moose;    
90     
91     ::lives_ok {
92         with 'List::Immutable', 'List';
93     } '... successfully composed roles together';    
94     
95 }
96
97 {
98     my $coll = My::List1->new;
99     isa_ok($coll, 'My::List1');
100
101     ok($coll->does('List'), '... $coll does List');
102     ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
103
104     ok($coll->is_empty, '... we have an empty collection');
105     is($coll->length, 0, '... we have a length of 1 for the collection');    
106 }
107
108 {
109     my $coll = My::List2->new;
110     isa_ok($coll, 'My::List2');
111
112     ok($coll->does('List'), '... $coll does List');
113     ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
114
115     ok($coll->is_empty, '... we have an empty collection');
116     is($coll->length, 0, '... we have a length of 1 for the collection');    
117 }
118
119 {
120     my $coll = My::List1->new('::' => [ 1 .. 10 ]);
121     isa_ok($coll, 'My::List1');
122
123     ok($coll->does('List'), '... $coll does List');
124     ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
125
126     ok(!$coll->is_empty, '... we do not have an empty collection');
127     is($coll->length, 10, '... we have a length of 10 for the collection');   
128     
129     is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value');
130
131     my $coll2 = $coll->apply(sub { $_[0] * $_[0] });
132     isa_ok($coll2, 'My::List1');
133     
134     is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same');    
135     is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed');     
136 }
137
138 {
139     my $coll = My::List2->new('::' => [ 1 .. 10 ]);
140     isa_ok($coll, 'My::List2');
141
142     ok($coll->does('List'), '... $coll does List');
143     ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
144
145     ok(!$coll->is_empty, '... we do not have an empty collection');
146     is($coll->length, 10, '... we have a length of 10 for the collection');   
147     
148     is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value');
149
150     my $coll2 = $coll->apply(sub { $_[0] * $_[0] });
151     isa_ok($coll2, 'My::List2');
152     
153     is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same');    
154     is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed');     
155 }
156
157
158
159
160
161
162
163