Perl Either

Either.pm

package Either;
use strict; use warnings;
use Exporter qw/import/;
use Function::Parameters;
use syntax qw(try);
use vars qw{$AUTOLOAD};

our @EXPORT = qw/left right either either_try/;

use overload '""'  => '_stringify';

# Exports
fun left($obj)  { bless [$obj], __PACKAGE__ . '::Left' }
fun right($obj) { bless [$obj], __PACKAGE__ . '::Right' }

# Helper to wrap values in Either: undef -> left(), otherwise right()
fun either($obj) { defined($obj) ? right($obj) : left($obj) }

fun either_try(CodeRef $f, @args) {
    try {
        return right $f->(@args);
    } catch ($e) {
        return left $e;
    }
}

# Class Methods

# Functions passed to map() should return plain values, never Either values
method map(CodeRef $f) {
    $self->flat_map(fun($val) { right $f->($val) });
}

# Functions passed to flat_map() should *always* return an Either object
method flat_map (CodeRef $f) {
    #TODO(wwolf): Check that $f->() return value is Either Type
    return $self->is_left ? $self : $f->($self->value);
}

method map_try(CodeRef $f) {
    $self->flat_map(fun(@args) {
        either_try fun { $f->(@args) };
    });
}

method is_left  { ref($self) eq __PACKAGE__ . '::Left' }
method is_right { ref($self) eq __PACKAGE__ . '::Right' }
method value    { $self->[0] }

# Delegate missing method calls to the held object if Right
# Return $self if $left
# This allows method chaining on Either objects
method AUTOLOAD(@args) {
    my $method = $AUTOLOAD =~ s/.*:://r;
    $self->flat_map(fun($val) { either_try fun{ $val->$method(@args) } });
}

# Needed by AUTOLOAD
method DESTROY {}

# HashRef key accessor helper
method hk($key) {
    $self->flat_map(fun($val) { either_try fun{ $val->{$key} }});
}

# ArrayRef index accessor helper
method ai(Int $index) {
    $self->flat_map(fun($val) { either_try fun{ $val->[$index] }});
}

method _stringify { ref($self) . "(" . ($self->value//'') =~ s/\n//gr . ")" }

package Either::Left;
use parent -norequire, 'Either';

package Either::Right;
use parent -norequire, 'Either';

1;

Either.t

use Test::Core;
use Function::Parameters;
use v5.14;

use Either;

subtest 'constructors' => fun {
    subtest 'right' => fun {
        my $rE = right(1);
        ok $rE->is_right;
        ok !$rE->is_left;
        is $rE->value => 1;
    };

    subtest 'left' => fun {
        my $lE = left(2);
        ok !$lE->is_right;
        ok $lE->is_left;
        is $lE->value => 2;
    };

    subtest 'either' => fun {
        my $valE = either(undef);
        ok $valE->is_left, 'undef value becomes Left';

        $valE = either(0);
        ok $valE->is_right, '0 value becomes Right';

        $valE = either("string");
        ok $valE->is_right, 'truthy value becomes Right';
    };

    subtest 'either_try' => fun {
        my $valE = either_try(fun { 1 });
        ok $valE->is_right, 'scalar becomes Right';

        $valE = either_try(fun { die 'lol' });
        ok $valE->is_left, 'die becomes Left';
        like $valE->value => qr/lol/;
    };
  };


subtest 'map and map_try' => fun {
    subtest 'Right' => fun {
        subtest 'successful' => fun {
            my $valE = right(1)->map(method { $self++ });
            is $valE->value => 1;
        };

        subtest 'dies' => fun {
            my $exc = exception { right(1)->map(fun { die 'oops' }) };
            ok $exc, 'map() throws on function dying';
            like $exc => qr/oops/;
        };

        subtest 'map_try doesnt die' => fun {
            my $valE = right(1)->map_try(fun { die 'oops' });
            ok $valE->is_left, 'map_try() does not die, returns Left';

        }
    };
    subtest 'Left' => fun {
        my $valE = left(1)->map(fun { die 'shouldnt die' });
        is $valE->value => 1;
    };
};

subtest 'flat_map' => fun {
    subtest 'Right' => fun {
        subtest 'successful' => fun {
            my $valE = right(1)->flat_map(method { right $self++ });
            is $valE->value => 1;
        };

        #TODO(wwolf): Test that flat_map throws an error if $f() does
        # not return an Either type
        #subtest 'error on invalid function' => fun { };

        subtest 'dies' => fun {
            my $exc = exception { right(1)->flat_map(fun { die 'oops' }) };
            ok $exc, 'map() throws on function dying';
            like $exc => qr/oops/;
        };
    };
    subtest 'Left' => fun {
        my $valE = left(1)->map(fun { die 'shouldnt die' });
        is $valE->value => 1;
    };
};

subtest 'accessor helpers' => fun {
    subtest 'hashref hk()' => fun {
        my $valE = right({a => 'A'})->hk('a');
        ok $valE->is_right, 'hk returns Either(val)';
        is $valE->value => 'A', 'hk contains proper value from HashRef';
        ok $valE->hk('invalidKey')->is_left, 'hk does not fail on non-hashref';

        $valE = right('non-hashref')->hk('key1')->hk('key2');
        ok $valE->is_left, 'Get a Left after invalid hashref access attempt';
        like $valE->value => qr/Can't use string.+as a HASH/, 'contains error';
    };

    subtest 'arrayref ai()' => fun {
        my $valE = right([qw(1 2 3)])->ai(2);
        ok $valE->is_right, 'ai returns Either(val)';
        is $valE->value => 3, 'ai contains proper value from ArrayRef';
        ok $valE->ai(1)->is_left, 'ai does not fail on non-arrayref';

        $valE = right('non-arrayref')->ai(1)->ai(2);
        ok $valE->is_left, 'Get a Left after invalid arrayref access attempt';
        like $valE->value => qr/Can't use string.+as an ARRAY/, 'contains error';

        subtest 'ai requires int param' => fun {
            my $exc = exception { right([1])->ai('test') };
            ok $exc;
            like $exc => qr/failed for 'Int'/, 'ai requires Int';
        };
    };

    subtest 'method accessors' => fun {
        subtest 'valid methods' => fun {
            my $obj = MO(
                set  => method($s)    { $self->{state} = $s; return $self },
                add1 => method(@args) { $self->{state}++; return $self },
                add  => method(@args) {
                    $self->{state} += $args[0] + $args[1]; return $self;
                },
            );
            my $valE = right($obj)->set(4)->add(1,3)->add1;
            ok $valE->is_right, 'can chain good methods';
            is $valE->value->{state} => 9, 'got correct value';
        };

        subtest 'invalid methods' => fun {
            my $valE = right(1)->set(1)->call('three')->nope(18);
            ok $valE->is_left, 'can chain bad methods';
            like $valE->value => qr/Can't call method "set"/, 'got correct err';
        };
    };
};


done_testing;