maybe_monad.pl

BEGIN{ 
	$INC{'Util.pm'} = '-';

	package Util;
	use strict;
	use warnings;
	use Exporter qw/import/;
	our @EXPORT = qw/comp nt_nt T_nt nt_T/;

	sub comp($$){
		my ($arrow1, $arrow2) = @_;
		return sub {
			return $arrow1->( $arrow2->(@_) );
		}
	}

	sub nt_nt{
		my ($nt1, $nt2) = @_;
		# 各対象に対するコンポーネントを合成(今回は全部同じコンポーネント)
		comp $nt1, $nt2;
	}

	sub T_nt{
		my ($T, $nt) = @_;
		return $T->($nt);
	}

	sub nt_T{
		my ($nt, $T) = @_;
		# 対象TAによる$ntのコンポーネントだが、
		# 任意の対象について同じコンポーネントとしているので何もしなくていい
		return $nt;
	}
}

package Monad;
use Any::Moose;
use Util;

# 自己関手 (射の写像)
has T_arrow => (
	isa      => 'CodeRef',
	is       => 'ro',
	required => 1,
);

# モナドの単位元となる自然変換 (ID -> T)
has eta => (
	isa      => 'CodeRef',
	is       => 'ro',
	required => 1,
);

# モナドの乗法となる自然変換 (TT -> T)
has mu => (
	isa      => 'CodeRef',
	is       => 'ro',
	required => 1,
);

sub flat {
	my $self = shift;
	return sub {
		my $arrow = shift;  # A -> TB
		# TA -> TB
		return comp $self->mu, $self->T_arrow->( $arrow );
	};
}

no Any::Moose;
1;


package main;
use strict;
use warnings;
use Util;

sub just(@) { [@_] }

sub nothing() { 'NOTHING' }

my $list_monad = Monad->new(
	T_arrow => sub {
		my $arrow = shift;  # A -> B
		return sub {
			my $tx = shift; # TA -> TB
			ref $tx or return nothing;
			return just $arrow->(@$tx);
		};
	},
	eta => sub {
		return just @_;
	},
	mu => sub {
		my $ttx = shift;
		ref $ttx or return nothing;
		return wantarray ? @$ttx : $ttx->[0];
	},
);


use Coro::Generator;
use Devel::Caller qw/caller_cv/;

sub do_monad(&$){
	my ($code, $monad_class) = @_;

	return sub {
		my @args = @_;

		my $result_as_monad;
		my $instruction_iter = generator {
			$result_as_monad = $code->(@args);
			yield undef while 1;
		};

		my $next_kleisli = sub {
			my @val = @_;
			my $monad = $instruction_iter->(@val);
			if($monad){
				return $monad_class->flat->(caller_cv 0)->($monad);
			}else{
				return $result_as_monad;
			}
		};

		return $next_kleisli->();
	};
}

sub retrieve($){
	my $monad = shift;
	return yield $monad;
}


my $kleisli_div = sub {
    my ($x, $y) = @_;
    return $y ? just($x / $y) : nothing;
};

my $kleisli_divs = do_monad {
	my $v1 = retrieve $kleisli_div->(3.0, 1.0);
	my $v2 = retrieve $kleisli_div->(2.0, 1.0);
	return $kleisli_div->($v1, $v2);
} $list_monad;

my $maybe_value = $kleisli_divs->();

print +(ref $maybe_value ? @$maybe_value : $maybe_value), "\n";