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