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