package Data::Monad::Base::Sugar;
use strict;
use warnings;
use Scalar::Util qw/blessed weaken/;
use Exporter qw/import/;

our @EXPORT = qw/pick satisfy yield let/;

our $_PICK = our $_SATISFY = 
    our $_YIELD = our $_LET = sub { die "called outside for()." };
sub pick($;$)  { $_PICK->(@_)    }
sub satisfy(&) { $_SATISFY->(@_) }
sub yield(&)   { $_YIELD->(@_)   }
sub let($$)    { $_LET->(@_)     }

sub _capture {
    my $ref = pop;

    return $ref->capture(@_) if blessed $ref && $ref->can('capture');

    ref $ref eq 'ARRAY' ? (@$ref = @_) : ($$ref = $_[0]);
}

sub _tuple { bless [@_], 'Data::Monad::Base::Sugar::Tuple' }
sub Data::Monad::Base::Sugar::Tuple::capture {
    my ($self, $result) = @_;
    blessed $result && $result->isa(ref $self)
                                            or die "[BUG]result is not tuple";

    _capture @{$result->[$_]} => $self->[$_] for 0 .. $#$self;
}

sub for(&) {
    my $code = shift;

    my @blocks;
    {
        local $_PICK = sub {
            my ($ref, $block) = @_;
            $block = $ref, $ref = undef unless defined $block;

            push @blocks, {ref => $ref, block => $block};
        };

        local $_YIELD = sub {
            my $block = shift;

            $blocks[$#blocks]->{yield} = $block;
        };

        local $_SATISFY = sub {
            my $predicate = shift;
            die "satisfy() should be called after pick()."
                                                          unless @blocks;

            my $slot = $#blocks;
            my $orig_block = $blocks[$slot]->{block};
            my $orig_ref   = $blocks[$slot]->{ref};

            $blocks[$slot]->{block} = sub {
                $orig_block->()->filter(sub {
                    _capture @_ => $orig_ref;
                    delete $blocks[$slot]; # destroy the cyclic ref
                    $predicate->(@_);
                });
            };
        };

        local $_LET = sub {
            my ($ref, $block) = @_;

            unless (@blocks) {
                # eval immediately because we aren't in any lambdas.
                _capture $block->() => $ref;
                return;
            }

            my $slot = $#blocks;
            my $orig_block = $blocks[$slot]->{block};
            my $orig_ref   = $blocks[$slot]->{ref};

            # Capture multiple values.
            # A tupple is used in "p <- e; p' = e'" pattern.
            # See: http://www.scala-lang.org/docu/files/ScalaReference.pdf
            $blocks[$slot]->{ref} = _tuple $orig_ref, $ref;
            $blocks[$slot]->{block} = sub {
                $orig_block->()->map(sub {
                    _capture @_ => $orig_ref;
                    delete $blocks[$slot]; # destroy the cyclic ref
                    return _tuple [@_], [$block->()];
                });
            };
        };
        $code->();
    }

    my $weak_loop;
    my $loop = sub {
        my @blocks = @_;

        my $info = shift @blocks;
        my $m = $info->{block}->();
        my $ref = $info->{ref};

        if ($info->{yield}) {
            return $m->map(sub {
                _capture @_ => $ref;
                $info->{yield}->();
            });
        } elsif (@blocks) {
            my $retained_loop = $weak_loop;
            return $m->flat_map(sub {
                _capture @_ => $ref;
                $retained_loop->(@blocks);
            });
        } else {
            return $m;
        }
    };
    weaken($weak_loop = $loop);

    return $loop->(@blocks);
}

1;

__END__

=head1 NAME

Data::Monad::Base::Sugar - Syntax sugars for Data::Monad.

=head1 SYNOPSIS

  use Data::Monad::Base::Sugar;
  use Data::Monad::List;

  my $result = Data::Monad::Base::Sugar::for {
      pick \my $x => sub { scalar_list 1 .. 100 };
      pick \my $y => sub { scalar_list $x .. 100 };
      pick \my $z => sub { scalar_list $y .. ($x + $y > 100 ? 100 : $x + $y) };
      satisfy { $x**2 + $y**2 == $z**2 };
      yield { $x, $y, $z }
  };

=head1 DESCRIPTION

Data::Monad::Base::Sugar provides syntax sugars for Data::Monad.

The for method is known as "do" expression in Haskell.

=head1 METHODS

=over 4

=item $monad = Data::Monad::Base::Sugar::for { ... }

DSL to create a monad value. You can use following functions in the block,
and shouldn't write sentences other than following functions in the block.

All sentences are connected by C<flat_map> automatically.

=over 4

=item pick \$value, \&f

=item pick \@values, \&f

=item pick \&f

Retrieves values from the monad, and puts it in C<$value>. C<\&f> should return
any Monad objects.

You should handle C<$value> as read-only and should use C<$value> only in
code-refs of other DSL functions.

=item let \$value, \&f

=item let \@values, \&f

Captures the value into C<$value>. C<\&f> can return any values, and the result
is put in C<$value> directly.

=item satisfy { ... }

Filters values by using C<filter>.

=item yield { ... }

Wraps values in a Monad object by using C<unit> and returns the monad object.
This sentence should be the last line of DSL.

=back

=back

=head1 AUTHOR

hiratara E<lt>hiratara {at} cpan.orgE<gt>

=head1 SEE ALSO

L<Data::Monad::Base::Monad>

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut