Changelogging
[gitmo/Mouse.git] / t / 200_examples / 003_example.t
CommitLineData
7a50b450 1#!/usr/bin/perl
2
3use strict;
4use warnings;
5
6use Test::More tests => 30;
7use Test::Exception;
8
9sub U {
10 my $f = shift;
11 sub { $f->($f, @_) };
12}
13
14sub Y {
15 my $f = shift;
16 U(sub { my $h = shift; sub { $f->(U($h)->())->(@_) } })->();
17}
18
19{
20 package List;
21 use Mouse::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 Mouse::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 Mouse;
83
84 ::lives_ok {
85 with 'List', 'List::Immutable';
86 } '... successfully composed roles together';
87
88 package My::List2;
89 use Mouse;
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