package Text::Wigwam::Library::Conditionals;

    use strict;
    use warnings;
    no warnings q/uninitialized/;
    no warnings q/recursion/;
    our $VERSION = '0.01';

    use base q/Exporter/;

    use Text::Wigwam::Const( q/:all/ );

    our %EXPORT_TAGS = (
        all => [
          qw /
            _proto_ifelse  _ifelse
            _proto_given   _given
            _proto_when    _when
            _proto_switch  _switch
            _proto_case    _case
            _proto_default _default
            _proto_unless  _unless
            _proto_if      _if
            _proto_elsif   _elsif
            _proto_else    _else
          /
        ],
        ifelse  => [ qw/ _proto_ifelse  _ifelse / ],
        given   => [ qw/ _proto_given   _given / ],
        when    => [ qw/ _proto_when    _when / ],
        switch  => [ qw/ _proto_switch  _switch / ],
        case    => [ qw/ _proto_case    _case / ],
        default => [ qw/ _proto_default _default / ],
        unless  => [ qw/ _proto_unless  _unless / ],
        if      => [ qw/ _proto_if      _if / ],
        elsif   => [ qw/ _proto_elsif   _elsif / ],
        else    => [ qw/ _proto_else    _else / ],
    );
    our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
    our @EXPORT = qw( );

=head1 Name

Text::Wigwam::Library::Conditionals - A Wigwam directive library.

=head1 Description

This library provides directives which are useful for performing logical
operations.

=head1 Usage

The directives within this library can be imported into specific branches of
the directive tree (which transcends from  C<Text::Wigwam::Directives>) via
plug-ins or modules using one of the following techniques.

 package Text::Wigwam::Directives::some::arbitrary::branch;
 # import everything
 use Text::Wigwam::Library::Conditionals( q/:all/ );

 package Text::Wigwam::Directives::another::arbitrary::branch;
 # import selectively
 use Text::Wigwam::Library::Conditionals(
  qw/ :given :when :switch :case :default :unless :if :elsif :else :ifelse /
 );

=head1 Directives

=cut

sub _proto_given { [STRING, STRING], [qw/When Default/] }
sub _given {
    my ($Api) = @_;
#    my $val = $Api->get_arg;
    $Api->push_global( given => \$Api->get_arg );
#    $Api->set_global( given => \$val );
    $Api->get_arg; # Execute the block, toss the result

    if( my $when = $Api->get_global(q/When/) ){
         # dereference 'When' global
        $Api->del_global( 'given' );
        return $$when;
    }

#    if( $Api->is_expr($default) ){

    return unless my $default = $Api->get_global( q/Default/ );
    my $result = $default->execute;
    $Api->del_global( 'given' );
    return $result;
}

=head2 #given I<expr> I<block>

Begins a C<#given>/C<#when> tree which returns the second argument of the
first C<#when> expression that contains a match to #given's I<expr> value
within its list. If the block contains a C<#default> statement, it will only
be processed if no C<#when> statements matched.

 [!!
  #define action "take"
  #given action {
     #when "take" "taken"
     #when "give" "given"
     #default "no action"
  }
  /* output: taken */
 !!]

This provides an alternative to C<#If>/C<#Elsif>/C<#Else> trees.

=cut

sub _proto_when { [ ARRAY, ANY ] }
sub _when {
    my ($Api) = @_;
    my $list = $Api->get_arg;
    my $key = $Api->get_global( q/given/ ) or do {
        $Api->kill_arg(1);
        $Api->exception('#when must be used within a #given block');
        return;
    };
    if ( grep { $_ eq $$key } @$list ){
         # Store as a reference to force it true.
        $Api->set_global( When => \$Api->get_arg );
        return;
    }
    $Api->kill_arg(1);
    return;
}

=head2 #when I<list> I<block>

The C<#when> directive is used inside of a C<#given> block to match a value in
I<list> to a I<block>. Should an item in the I<list> evaluate to the value
specified by the encompassing C<#given> directive's expression, the I<block>
is executed by the C<#given> directive and further processing of I<block> is
terminated.

 [!!
  #given #random 1 20 {
    #when ( 2 3 5 7 11 13 17 19 ) { :given " is a prime number" }
    #default { :given " is a boring number" }
  }
 !!]

=cut

sub _proto_switch {[STRING, STRING], [qw/switch Case Break Default/]}
sub _switch {
    my ($Api) = @_;
    $Api->set_global( switch => $Api->get_arg );
    my $case = $Api->set_global( Case => [] );
    $Api->get_arg; # Execute the block, toss the result
    return join( '', @$case ) if scalar @$case;
    my $default = $Api->get_global( q/Default/ )
      or return;
    return unless $Api->is_expr($default);
    $Api->set_global( Break => 0 );
    return $default->execute;
}

=head2 #switch I<expr> I<block>

Begins a C<#switch>/C<#case> tree which returns the concatenated results of
all C<#case> expressions within its block that contain a match for I<expr>'s
value. Unlike #given/#when, no implied break occurs when a match is made,
though you may explicitly invoke C<#break> to interrupt any further processing
of the tree. If the block contains a C<#default> statement, it will only be
processed if no C<#case> statements matched.

  [!!
  #define group.A ( 1 2 3 4 5 6 )
  #define group.B ( 5 6 7 8 9 0 )
  #switch #assign guess #random 0 10 {
    #case group.A #push grouplist "A"
    #case group.B #push grouplist "B"
    #default #throw { "Invalid guess: " guess }
  }
  guess " is a member of group(s): " #join ", " grouplist
  !!]

=cut

sub _proto_case { [ ARRAY, STRING ] }
sub _case {
    my ($Api) = @_;
    my $list = $Api->get_arg;
    my $key = $Api->get_global( q/switch/ );
    my $case = $Api->get_global( q/Case/ ) or do {
        $Api->kill_arg(1);
        $Api->exception('#case must be used within a #switch block');
        return;
    };
    if ( grep { $_ eq $key } @$list ){
        push( @$case, $Api->get_arg );
        return;
    }
    $Api->kill_arg(1);
    return;
}

=head2 #case I<list> I<block>

The C<#case> directive is used inside of a C<#switch> block to match a value
in I<list> to a I<block>. Should an item in the I<list> evaluate to the value
specified by the encompassing C<#switch> directive's expression, the I<block>
is executed and its results are added to the queue. The tree continues to
process until the end of the block is reached, unless explicitly interrupted,
such as with C<#break>.

=cut

sub _proto_default { [ ANY|EXPR ] }
sub _default {
    my ($Api) = @_;
    $Api->set_global( Default => $Api->get_arg );
    return;
}

=head2 #default I<block>

Specifies a default expression for a C<#given>/C<#when> or C<#switch>/C<#case>
tree which is executed in the event that all C<#when> or C<#case> conditions
within the block fail to match.

 [!!
  #define selection "X"
  "You've selected "
  #given selection {
     #when "A" "Apple"
     #when "B" "Banana"
     #when "C" "Cantelope"
    #default { selection ", which is not on the menu" }
  }
  /* output:
   You've selected X, which is not on the menu
  */
 !!]

=cut

sub _proto_unless{ [ BOOLEAN, EXPR|BLOCK ] }
sub _unless {
    my ($Api) = @_;
    my $doelse = $Api->set_global( Do_else => \do { my $z=0 } );
    return $Api->get_arg->execute unless $Api->get_arg;
    $$doelse = 1;
    $Api->kill_arg(1);
    return;
}

=head2 #unless I<cond> I<block>

The reverse logic version of the C<#if> directive.

 [!!
   #unless 1 'this will not execute'
   #else 'This will'
 !!]

=cut

sub _proto_if { [ BOOLEAN, EXPR|BLOCK ] }
sub _if {
    my ($Api) = @_;
    my $doelse = $Api->set_global( Do_else => \do { my $z=0 } );
    return $Api->get_arg->execute if $Api->get_arg;
    $$doelse = 1;
    $Api->kill_arg(1);
    return;
}

=head2 #if I<cond> I<block>

Executes I<block> only if I<cond> evaluates to true.

 [!! #if 0 "output nothing" !!]
 [!! #if 1 "this is output" !!]

Can be used in conjunction with C<#elsif> and C<#else>.

 [!!
  #if 0 "not processed"
  #elsif 0 "not processed"
  #else "This prevails"
  /* output:
   This prevails
  */
 !!]

Unlimited nesting is supported.

 [!!
   #if 1 {
    #if 0 "no" #else "prevails"
   }
   #else "no"
   /* outputs: prevails */
 !!]

 [!!
  #if 1 {
     #if 0 {
         #if 1 "No"
     }
     #else "prevails"
  }
  #else "Nope"
  /* output: prevails */
 !!]

=cut

sub _proto_elsif { [ BOOLEAN, EXPR|BLOCK ] }
sub _elsif {
    my ($Api) = @_;
    my $doelse = $Api->get_global( q/Do_else/ ) or do {
        $Api->kill_arg(2);
        $Api->exception( '#elsif must follow #if or #unless.' );
        return
    };
    unless( $$doelse ){
        $Api->kill_arg(2);
        return;
    }
    if( $Api->get_arg ){
        $$doelse = 0;
        return $Api->get_arg->execute;
    }
    $Api->kill_arg(1);
    return;
}

=head2 #elsif I<cond> I<block>

Executes I<block> if all preceding C<#if> and C<#elsif> conditions within the
common block scope have failed and if I<cond> evaluates true.

 [!!
  #if 0 "noway"
  #elsif 1 {
     #if 0 "no"
     #elsif 0 "unlikely"
     #else "prevails"
  }
  #else "nope"
  /* output: prevails */
 !!]

=cut

sub _proto_else{ [ EXPR|BLOCK ] }
sub _else {
    my ($Api) = @_;
    my $doelse = $Api->get_global( q/Do_else/ ) or do {
        $Api->kill_arg(1);
        $Api->exception( '#else must follow #if or #unless.' );
        return;
    };
    unless( $$doelse ){
        $Api->kill_arg(1);
        return;
    }
    $Api->set_global( Do_else => undef );
    return $Api->get_arg->execute;
}

=head2 #else I<block>

Executes I<block> if all preceding C<#if> & C<#elsif> expressions within the
common block scope have failed.

 [!!
  #if 1 {
     #if 0 "no"
     #else "prevails"
  }
  #else "nope"
  /* output: prevails */
 !!]

=cut

sub _proto_ifelse { [ BOOLEAN, EXPR, EXPR ] }
sub _ifelse {
    my ($Api) = @_;
    my( $cond, $texpr, $fexpr ) = (
        $Api->get_arg,
        $Api->get_arg,
        $Api->get_arg
    );
    return $cond ? $texpr->execute : $fexpr->execute;
}

=head2 #ifelse I<cond> I<block1> I<block2>

If I<cond> evaluates to true, I<block2> is destroyed and the results of
I<block1> are returned. Otherwise, I<block1> is destroyed and the results of
I<block2> are returned.

The following example assigns ( 1 2 3 4 5 ) to the array variable.

 [!! #define array #ifelse 0 ( 1 2 3 4 5 ) ( 6 7 8 9 ) !!]

=cut

sub init_lib {
    $_[0]->new_global( BLOCK => q/Do_else/ );
    $_[0]->new_eflag( LOCAL => q/Break/ );
    $_[0]->new_eflag( LOCAL => q/When/ );
    $_[0]->new_eflag( LOCAL => q/Continue/ );
}

1;
