Changelogging

[gitmo/Mouse.git] / t / 200_examples / 003_example.t

#!/usr/bin/perl

use strict;
use warnings;

use Test::More tests => 30;
use Test::Exception;

sub U {
    my $f = shift;
    sub { $f->($f, @_) };
}

sub Y {
    my $f = shift;
    U(sub { my $h = shift; sub { $f->(U($h)->())->(@_) } })->();
}

{
    package List;
    use Mouse::Role;

    has '_list' => (
        is       => 'ro',
        isa      => 'ArrayRef',
        init_arg => '::',
        default  => sub { [] }
    );

    sub head { (shift)->_list->[0] }
    sub tail {
        my $self = shift;
        (ref $self)->new(
            '::' => [
                @{$self->_list}[1 .. $#{$self->_list}]
            ]
        );
    }

    sub print {
        join ", " => @{$_[0]->_list};
    }

    package List::Immutable;
    use Mouse::Role;

    requires 'head';
    requires 'tail';

    sub is_empty { not defined ($_[0]->head) }

    sub length {
        my $self = shift;
        (::Y(sub {
            my $redo = shift;
            sub {
                my ($list, $acc) = @_;
                return $acc if $list->is_empty;
                $redo->($list->tail, $acc + 1);
            }
        }))->($self, 0);
    }

    sub apply {
        my ($self, $function) = @_;
        (::Y(sub {
            my $redo = shift;
            sub {
                my ($list, $func, $acc) = @_;
                return (ref $list)->new('::' => $acc)
                    if $list->is_empty;
                $redo->(
                    $list->tail,
                    $func,
                    [ @{$acc}, $func->($list->head) ]
                );
            }
        }))->($self, $function, []);
    }

    package My::List1;
    use Mouse;

    ::lives_ok {
        with 'List', 'List::Immutable';
    } '... successfully composed roles together';

    package My::List2;
    use Mouse;

    ::lives_ok {
        with 'List::Immutable', 'List';
    } '... successfully composed roles together';

}

{
    my $coll = My::List1->new;
    isa_ok($coll, 'My::List1');

    ok($coll->does('List'), '... $coll does List');
    ok($coll->does('List::Immutable'), '... $coll does List::Immutable');

    ok($coll->is_empty, '... we have an empty collection');
    is($coll->length, 0, '... we have a length of 1 for the collection');
}

{
    my $coll = My::List2->new;
    isa_ok($coll, 'My::List2');

    ok($coll->does('List'), '... $coll does List');
    ok($coll->does('List::Immutable'), '... $coll does List::Immutable');

    ok($coll->is_empty, '... we have an empty collection');
    is($coll->length, 0, '... we have a length of 1 for the collection');
}

{
    my $coll = My::List1->new('::' => [ 1 .. 10 ]);
    isa_ok($coll, 'My::List1');

    ok($coll->does('List'), '... $coll does List');
    ok($coll->does('List::Immutable'), '... $coll does List::Immutable');

    ok(!$coll->is_empty, '... we do not have an empty collection');
    is($coll->length, 10, '... we have a length of 10 for the collection');

    is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value');

    my $coll2 = $coll->apply(sub { $_[0] * $_[0] });
    isa_ok($coll2, 'My::List1');

    is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same');
    is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed');
}

{
    my $coll = My::List2->new('::' => [ 1 .. 10 ]);
    isa_ok($coll, 'My::List2');

    ok($coll->does('List'), '... $coll does List');
    ok($coll->does('List::Immutable'), '... $coll does List::Immutable');

    ok(!$coll->is_empty, '... we do not have an empty collection');
    is($coll->length, 10, '... we have a length of 10 for the collection');

    is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value');

    my $coll2 = $coll->apply(sub { $_[0] * $_[0] });
    isa_ok($coll2, 'My::List2');

    is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same');
    is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed');
}