t/200_examples/003_example.t

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