t/203_example.t

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