Shut up "calling new on object" warning
[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         (ref $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 (ref $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